Excelをcsv形式に一括変換する

エクセルをcsvに一括変換

手順：

• エクスポートしたいExcelファイルを1つのフォルダにまとめ、csvファイルを保存するフォルダを決めておく
• Excelファイルを新たに作成するには、ファイル>>オプション をクリックし、開発ツールにチェックを入れる。
• メニューバーの「開発ツール」をクリックし、その下のVisual Basicをクリックする
• 左の欄でSheet1をダブルクリックしてコード編集ウィンドウを開き、以下のコードを入力します。
• メニューバー上の「実行」をクリックして、実行サブプロセス:SaveToCSVs()を選択して、変換中に復数のExcelウィンドウが自働的に表示されてから閉じる。完了したら設定したフォルダを開くと、変換されたcsvファイルを見ることができる。

Sub getXlsxFilePathName()
    '******************
    'xlsxファイルのパス指定
    '******************
    Dim xlsxFilePath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            xlsxFilePath = .SelectedItems(1)
            Cells(6, 5).Value = xlsxFilePath & "\"
        End If
    End With
End Sub

Sub getOutputCsvFilePathName()
    '******************
    'Output_Csvファイルのパス指定
    '******************
    Dim OutputCsvFilePath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            OutputCsvFilePath = .SelectedItems(1)
            Cells(13, 5).Value = OutputCsvFilePath & "\"
        End If
    End With
End Sub

Sub SaveToCSVs()
    '******************
    'xlsxファイルをcsvファイルに変換
    '******************
    Dim fDir As String
    Dim wB As Workbook
    Dim wS As Worksheet
    Dim fPath As String
    Dim Spath As String
    Dim wB_Name As String
    Dim backupPath As String
    Dim BkFile As Object
    
    'エクセルファイルパス
    fPath = Cells(6, 5).Value
    
    'output_csvファイルパス
    Spath = Cells(13, 5).Value
    
    'fDir = Dir(fPath)
    'Do While (fDir <> "")
    Do
        fDir = Dir(fPath)
            If fDir = "" Then
                Exit Do
            End If
        
        If Right(fDir, 4) = ".xls" Or Right(fDir, 5) = ".xlsx" Then
            On Error Resume Next
            Set wB = Workbooks.Open(fPath & fDir)
            '開くxlsxファイルの名前 + "_" を保存
            wB_Name = wB.Name & "_"
            '開くxlsxファイルの名前でフォルダを作成
            Fold_sPath = Spath & wB.Name & "\"
            If MakeDir(Fold_sPath) Then
                'Proceed to export file
            End If
            'MsgBox (wB.Name)
            'wS.Name : シートの名前
            For Each wS In wB.Sheets
                'CSVファイル存在する場合、削除
                Kill Fold_sPath & wB_Name & wS.Name & ".csv"
                'エクセル名_シート名.csvの名前で保存
                wS.SaveAs Fold_sPath & wB_Name & wS.Name & ".csv", xlCSV
            Next wS
            
            wB.Close False
            Set wB = Nothing
        End If
        
        'backup
        backupPath = Spath & "backup_xlsx\"
            If MakeDir(backupPath) Then
                'Proceed to export file
            End If
        
        FileCopy fPath & fDir, backupPath & fDir
        Kill fPath & fDir
    Loop
    
    Set BkFile = CreateObject("Scripting.FileSystemObject")
        '文字列の最後の1桁（\）を落とす、fPathファイルの内容を元に戻す
        BkFile.CopyFolder Left(backupPath, Len(backupPath) - 1), Left(fPath, Len(fPath) - 1)
    Set BkFile = Nothing
    
    'backupPathフォルダ中の内容を削除
    If Dir(backupPath) <> "" Then Kill backupPath & "*.xlsx"
    
    'backupPathフォルダを削除
    On Error Resume Next
    RmDir Left(backupPath, Len(backupPath) - 1)
    
End Sub


Public Function MakeDir(ByVal strPath As String) As Boolean
'****************************************************************************************
'* Function: MakeDir
'*
'* Author:   TheSmileyCoder
'* Version:  1.0, Dated: 2012-03-01
'* Input:    Full path to directory desired. For example: "C:\Program Files\MyTool\
'*
'* Output:   True/False indicating whether or not creation was succesfull.
'****************************************************************************************
'*  Known issues
'   * No error handling for cases such as network drives,
'     with restricted permissions to create folders.
'   * No input validation
On Error GoTo err_Handler
   'Check if rightmost char is a \
      If Right(strPath, 1) = "\" Then
         'Strip it
         strPath = Left(strPath, Len(strPath) - 1)
      End If
   'Check if each individual directory exists, and if not, create it
      Dim strSplitPath() As String
      strSplitPath = Split(strPath, "\")
      Dim intI As Integer
      Dim strCombined As String
      'Loop through, creating each directory if needed
         For intI = 0 To UBound(strSplitPath)
            If intI <> 0 Then
               strCombined = strCombined & "\"
            End If
            strCombined = strCombined & strSplitPath(intI)
            If Dir(strCombined, vbDirectory) = "" Then
               MkDir strCombined
            End If
         Next
   'Code ran to end without errors, so creation was succesfull
      MakeDir = True
      Exit Function
'**************************************
'*      Error Handler
'**************************************
err_Handler:
   MakeDir = False
   MsgBox "Error " & Err.Number & " occured." & vbNewLine & Err.Description
End Function

---

問題の記述

例えば:実行した后に複数のCSVファイルが現れて、ファイル名はそれぞれ「.csv」、".csv.csv"、".xlsx"で、しかしすべてピリオド区切り値ファイルで、どこが間違えたことをお聞きしますか???

            For Each wS In wB.Sheets
                wS.SaveAs Fold_sPath & wB_Name & wB.Name & ".csv", xlCSV
            Next wS

---

原因分析:

wB.Name が開いているExcelの名前を表していますが、wSというSheetを再保存すると、実際には　***.csv 　このファイルを複数回保存され、そのたびに& ".csv"という拡張子が追加されるため、". csv.csv" という重複する場合がある。

---

解決策：

wB.Name という拡張子をwS.Nameに変更し、wS.Nameは現在ループしているSheetの名前を表し、
この名前は元の Excel では唯一無二であり、".csv.csv"のように拡張子が重複することはない。
以下のように修正する：

            For Each wS In wB.Sheets
                wS.SaveAs Fold_sPath & wB_Name & wS.Name & ".csv", xlCSV
            Next wS