csv作成マクロ

Sub ConvertExcelToCSV()
    Dim folderPath As String
    Dim fileName As String
    Dim workbook As Workbook
    Dim sheet As Worksheet
    Dim csvPath As String
    Dim fso As Object

    ' マクロが保存されているディレクトリを取得
    folderPath = ThisWorkbook.Path
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    ' ファイル検索用
    fileName = Dir(folderPath & "*.xls*")
    
    ' FileSystemObjectの準備
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 対象ディレクトリにファイルがない場合
    If fileName = "" Then
        MsgBox "マクロ実行ディレクトリにExcelファイルがありません。", vbExclamation
        Exit Sub
    End If
    
    ' Excelファイルごとに処理
    Do While fileName <> ""
        ' マクロファイル（ThisWorkbook）はスキップ
        If fileName <> ThisWorkbook.Name Then
            Set workbook = Workbooks.Open(folderPath & fileName, ReadOnly:=True)
            
            ' 各シートをCSVに変換
            For Each sheet In workbook.Sheets
                ' CSVファイルの保存パスを指定
                csvPath = folderPath & sheet.Name & ".csv"
                
                ' 既存のファイルがあれば削除
                If fso.FileExists(csvPath) Then
                    fso.DeleteFile csvPath, True ' True: 削除の確認をしない
                End If
                
                ' シートを一時的にCSVで保存
                sheet.Copy
                With ActiveWorkbook
                    .SaveAs Filename:=csvPath, FileFormat:=xlCSVUTF8
                    .Close SaveChanges:=False
                End With
            Next sheet
            
            ' Excelファイルを閉じる
            workbook.Close SaveChanges:=False
        End If
        
        fileName = Dir() ' 次のファイルへ
    Loop
    
    MsgBox "全てのExcelファイルをCSVに変換しました。", vbInformation
End Sub

Sub ConvertExcelToCSV()
    Dim folderPath As String
    Dim fileName As String
    Dim workbook As Workbook
    Dim sheet As Worksheet
    Dim tempCsvPath As String
    Dim finalCsvPath As String
    Dim fso As Object

    ' マクロが保存されているディレクトリを取得
    folderPath = ThisWorkbook.Path
    If Right(folderPath, 1) <> "\\" Then folderPath = folderPath & "\\"

    ' ファイル検索用
    fileName = Dir(folderPath & "*.xls*")

    ' FileSystemObjectの準備
    Set fso = CreateObject("Scripting.FileSystemObject")

    ' 対象ディレクトリにファイルがない場合
    If fileName = "" Then
        MsgBox "マクロ実行ディレクトリにExcelファイルがありません。", vbExclamation
        Exit Sub
    End If

    ' Excelファイルごとに処理
    Do While fileName <> ""
        ' マクロファイル（ThisWorkbook）はスキップ
        If fileName <> ThisWorkbook.Name Then
            Set workbook = Workbooks.Open(folderPath & fileName, ReadOnly:=True)

            ' 各シートをCSVに変換
            For Each sheet In workbook.Sheets
                ' ファイル名に無効な文字を除去
                Dim sanitizedSheetName As String
                sanitizedSheetName = Replace(sheet.Name, "/", "_")
                sanitizedSheetName = Replace(sanitizedSheetName, "\", "_")
                sanitizedSheetName = Replace(sanitizedSheetName, "?", "_")
                sanitizedSheetName = Replace(sanitizedSheetName, "*", "_")

                ' 一時的なCSVファイルの保存パス
                tempCsvPath = folderPath & sanitizedSheetName & "_temp.csv"
                finalCsvPath = folderPath & sanitizedSheetName & ".csv"

                ' 既存のファイルがあれば削除
                If fso.FileExists(finalCsvPath) Then
                    On Error Resume Next
                    fso.DeleteFile finalCsvPath, True
                    On Error GoTo 0
                End If

                ' シートを一時的にCSVで保存
                sheet.Copy
                On Error Resume Next
                With ActiveWorkbook
                    .SaveAs Filename:=tempCsvPath, FileFormat:=xlCSVUTF8
                    .Close SaveChanges:=False
                End With
                On Error GoTo 0

                ' BOMなしUTF-8で再保存
                If fso.FileExists(tempCsvPath) Then
                    Call SaveAsUtf8WithoutBOM(tempCsvPath, finalCsvPath)

                    ' 一時ファイルを削除
                    On Error Resume Next
                    fso.DeleteFile tempCsvPath, True
                    On Error GoTo 0
                Else
                    MsgBox "一時CSVファイルの作成に失敗しました: " & tempCsvPath, vbExclamation
                End If
            Next sheet

            ' Excelファイルを閉じる
            workbook.Close SaveChanges:=False
        End If

        fileName = Dir() ' 次のファイルへ
    Loop

    MsgBox "全てのExcelファイルをCSVに変換しました。", vbInformation
End Sub

Sub SaveAsUtf8WithoutBOM(tempPath As String, finalPath As String)
    Dim stream As Object
    Dim fso As Object
    Dim text As String

    ' FileSystemObjectの準備
    Set fso = CreateObject("Scripting.FileSystemObject")

    ' 一時ファイルの内容を読み込み
    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 2 ' テキストモード
    stream.Charset = "UTF-8"
    stream.Open
    stream.LoadFromFile tempPath
    text = stream.ReadText
    stream.Close

    ' BOMなしUTF-8で再保存
    stream.Type = 2 ' テキストモード
    stream.Charset = "UTF-8"
    stream.Open
    stream.WriteText text
    stream.Position = 3 ' BOMをスキップ
    stream.SaveToFile finalPath, 2 ' 新しいファイルに保存
    stream.Close

    Set stream = Nothing
    Set fso = Nothing
End Sub