将Excel批量转换为csv格式

Excel批量转换为csv

步骤：

• 把需要导出的Excel文件集中整理到一个文件夹中，并且确定一个文件夹用来保存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
    
    'excel文件路径
    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"
                'excel名称_工作表名称 & ".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")
        '去掉字符串的最后一位(\)，恢复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"，".xls"，但都是逗号分隔值文件，请问是哪里出错了啊???

            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