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

# エクセルをcsvに一括変換
手順：

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

```vb
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"`で、しかしすべてピリオド区切り値ファイルで、どこが間違えたことをお聞きしますか???

```vb
            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" `という重複する場合がある。
![在这里插入图片描述](https://img-blog.csdnimg.cn/7fc1cf7db4984454b28b4ee2f6ff0896.png)
![在这里插入图片描述](https://img-blog.csdnimg.cn/3337c03f6d9c4565a1aabd8d57a0e966.png)
![在这里插入图片描述](https://img-blog.csdnimg.cn/463cd063df6f4220b8bca60934b023a9.png)

---

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

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