批量将Excel文件转CSV
公司刚接了个大单，上千个客户资料，每个客户一个Excel文件，现在要全部转成CSV格式，好方便导入系统批量打印客户卡片。你默默打开第一个文件，点“另存为”，选CSV，保存……然后第二个，第三个……搞了不到100个，手就开始抽筋，眼睛都花了，心里无数个“点算”？（怎么办）
其实，这种重复劳动完全可以让电脑自己搞掂！今天就教你一段VBA代码，一键批量转换，让你瞬时间就搞定所有文件。
代码逻辑，简单讲一讲
这段代码就像一个勤劳的小秘书，它做这几件事：
- 1. 问你两个问题：先弹个窗口让你选“放Excel的文件夹”，再弹个窗口让你选“保存CSV的文件夹”。就像你告诉它：原材料在这里，成品放那里。
- 2. 自动扫描干活：它会把源文件夹里所有
.xlsx 和 .xls 文件找出来，一个个打开，把第一个工作表（默认是Sheet1）保存成CSV。如果目标文件夹已经有同名文件，它会聪明地给新文件加个编号，比如 客户资料_1.csv，绝不会覆盖你原来的文件。 - 3. 干完活汇报：全部搞定后弹个窗告诉你“一共处理了多少个文件”，清清楚楚。
整个过程全自动，你只需要最开始选两个文件夹，剩下就交给它。
完整代码（直接复制就能用）
把下面这段代码复制到VBA编辑器（按Alt+F11打开，插入-模块），然后运行宏ConvertExcelToCSV就行。
Option ExplicitSub ConvertExcelToCSV() Dim fdSrc As FileDialog Dim fdDest As FileDialog Dim srcFolder As String Dim destFolder As String Dim fileName As String Dim wb As Workbook Dim baseName As String Dim destPath As String Dim fileCount As Long Dim i As Integer Set fdSrc = Application.FileDialog(4) With fdSrc .Title = "请选择包含 Excel 文件的源文件夹" .AllowMultiSelect = False If .Show = -1 Then srcFolder = .SelectedItems(1) Else MsgBox "未选择源文件夹，操作取消。", vbExclamation Exit Sub End If End With Set fdDest = Application.FileDialog(4) With fdDest .Title = "请选择保存 CSV 文件的目标文件夹" .AllowMultiSelect = False If .Show = -1 Then destFolder = .SelectedItems(1) Else MsgBox "未选择目标文件夹，操作取消。", vbExclamation Exit Sub End If End With If Right(srcFolder, 1) <> "\" Then srcFolder = srcFolder & "\" If Right(destFolder, 1) <> "\" Then destFolder = destFolder & "\" Application.ScreenUpdating = False Application.DisplayAlerts = False Application.EnableEvents = False fileCount = 0 fileName = Dir(srcFolder & "*.xlsx") Do While fileName <> "" If ConvertOneFile(srcFolder & fileName, destFolder) Then fileCount = fileCount + 1 End If fileName = Dir() Loop fileName = Dir(srcFolder & "*.xls") Do While fileName <> "" If ConvertOneFile(srcFolder & fileName, destFolder) Then fileCount = fileCount + 1 End If fileName = Dir() Loop Application.ScreenUpdating = True Application.DisplayAlerts = True Application.EnableEvents = True If fileCount > 0 Then MsgBox "转换完成！共处理 " & fileCount & " 个文件。", vbInformation Else MsgBox "未找到任何 .xlsx 或 .xls 文件。", vbExclamation End If Set fdSrc = Nothing Set fdDest = NothingEnd SubPrivate Function ConvertOneFile(ByVal srcFullPath As String, ByVal destFolder As String) As Boolean Dim wb As Workbook Dim baseName As String Dim destPath As String Dim i As Integer Dim ext As String On Error Resume Next Set wb = Workbooks.Open(Filename:=srcFullPath, ReadOnly:=True, AddToMRU:=False) If Err.Number <> 0 Or wb Is Nothing Then On Error GoTo 0 ConvertOneFile = False Exit Function End If On Error GoTo 0 wb.Sheets(1).Activate baseName = Left(srcFullPath, InStrRev(srcFullPath, ".") - 1) baseName = Mid(baseName, InStrRev(baseName, "\") + 1) destPath = destFolder & baseName & ".csv" i = 1 Do While Dir(destPath) <> "" destPath = destFolder & baseName & "_" & i & ".csv" i = i + 1 Loop On Error Resume Next wb.SaveAs Filename:=destPath, FileFormat:=xlCSV, CreateBackup:=False If Err.Number <> 0 Then On Error GoTo 0 wb.Close SaveChanges:=False ConvertOneFile = False Exit Function End If On Error GoTo 0 wb.Close SaveChanges:=False ConvertOneFile = TrueEnd Function
使用小贴士
- • 代码只转换第一个工作表，如果你有其他需求，可以稍微改改。
- • 转换后的CSV文件编码和Excel默认一样，一般够用了。
- • 如果源文件有密码或损坏，它会自动跳过，不影响其他文件。
转发 + 
