关于excel：将工作表中的每个工作表保存为单独的CSV文件

Save each sheet in a workbook to separate CSV files

如何将每个工作表保存在Excel工作簿中，以使用宏分隔CSV文件？

我有一个具有多个工作表的excel，并且我正在寻找一个将每个工作表保存到单独的CSV (comma separated file)的宏。 Excel不允许您将所有工作表保存到不同的CSV文件。

@AlexDuggleby：您不需要复制工作表，可以直接保存它们。例如。：

1
2
3
4
5
6
7
8
9
10
11

Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String

SaveToDirectory ="C:\"

For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name, xlCSV
Next

End Sub

唯一的潜在问题是，您的工作簿将保存为最后的csv文件。如果需要保留原始工作簿，则需要另存为。

这是一个可以为您提供视觉文件选择器的工具，您可以选择要将文件保存到的文件夹，还可以选择CSV分隔符(我使用管道" |"，因为我的字段包含逗号，并且我不想处理带引号)：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126

' ---------------------- Directory Choosing Helper Functions -----------------------
' Excel and VBA do not provide any convenient directory chooser or file chooser
' dialogs, but these functions will provide a reference to a system DLL
' with the necessary capabilities
Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib"shell32.dll" _
Alias"SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib"shell32.dll" _
Alias"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle ="Select a folder."
' the dialog title
Else
bInfo.lpszTitle = Msg ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
X = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName =""
End If
End Function
'---------------------- END Directory Chooser Helper Functions ----------------------

Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim csvPath As String

Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", _
"Export To Text File")
'csvPath = InputBox("Enter the full path to export CSV files to:")

csvPath = GetFolderName("Choose the folder to export CSV files to:")
If csvPath ="" Then
MsgBox ("You didn't choose an export directory. Nothing will be exported.")
Exit Sub
End If

For Each wsSheet In Worksheets
wsSheet.Activate
nFileNum = FreeFile
Open csvPath &"\" & _
wsSheet.Name &".csv" For Output As #nFileNum
ExportToTextFile CStr(nFileNum), Sep, False
Close nFileNum
Next wsSheet

End Sub

Public Sub ExportToTextFile(nFileNum As Integer, _
Sep As String, SelectionOnly As Boolean)

Dim WholeLine As String
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String

Application.ScreenUpdating = False
On Error GoTo EndMacro:

If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If

For RowNdx = StartRow To EndRow
WholeLine =""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value ="" Then
CellValue =""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #nFileNum, WholeLine
Next RowNdx

EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True

End Sub

这是我的解决方案应该适用于Excel> 2000，但仅在2007年进行了测试：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49

Private Sub SaveAllSheetsAsCSV()
On Error GoTo Heaven

' each sheet reference
Dim Sheet As Worksheet
' path to output to
Dim OutputPath As String
' name of each csv
Dim OutputFile As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

' ask the user where to save
OutputPath = InputBox("Enter a directory to save to","Save to directory", Path)

If OutputPath <>"" Then

' save for each sheet
For Each Sheet In Sheets

OutputFile = OutputPath &"\" & Sheet.Name &".csv"

' make a copy to create a new book with this sheet
' otherwise you will always only get the first sheet
Sheet.Copy
' this copy will now become active
ActiveWorkbook.SaveAs FileName:=OutputFile, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next

End If

Finally:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

Exit Sub

Heaven:
MsgBox"Couldn't save all sheets to CSV." & vbCrLf & _
"Source:" & Err.Source &"" & vbCrLf & _
"Number:" & Err.Number &"" & vbCrLf & _
"Description:" & Err.Description &"" & vbCrLf

GoTo Finally
End Sub

(OT：我想知道SO是否会取代我的一些小博客)

基于Graham的答案，额外的代码将工作簿以其原始格式保存回其原始位置。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

Public Sub SaveWorksheetsAsCsv()

Dim WS As Excel.Worksheet
Dim SaveToDirectory As String

Dim CurrentWorkbook As String
Dim CurrentFormat As Long

CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
' Store current details for the workbook

SaveToDirectory ="C:\"

For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name, xlCSV
Next

Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
Application.DisplayAlerts = True
' Temporarily turn alerts off to prevent the user being prompted
' about overwriting the original file.

End Sub

从Alex进行的一个小修改是打开和关闭自动计算。

令人惊讶的是，未修改的代码在VLOOKUP上运行正常，但在OFFSET下失败。同时关闭自动计算功能可以大大加快保存速度。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54

Public Sub SaveAllSheetsAsCSV()
On Error GoTo Heaven

' each sheet reference
Dim Sheet As Worksheet
' path to output to
Dim OutputPath As String
' name of each csv
Dim OutputFile As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

' Save the file in current director
OutputPath = ThisWorkbook.Path

If OutputPath <>"" Then
Application.Calculation = xlCalculationManual

' save for each sheet
For Each Sheet In Sheets

OutputFile = OutputPath & Application.PathSeparator & Sheet.Name &".csv"

' make a copy to create a new book with this sheet
' otherwise you will always only get the first sheet

Sheet.Copy
' this copy will now become active
ActiveWorkbook.SaveAs Filename:=OutputFile, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next

Application.Calculation = xlCalculationAutomatic

End If

Finally:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

Exit Sub

Heaven:
MsgBox"Couldn't save all sheets to CSV." & vbCrLf & _
"Source:" & Err.Source &"" & vbCrLf & _
"Number:" & Err.Number &"" & vbCrLf & _
"Description:" & Err.Description &"" & vbCrLf

GoTo Finally
End Sub

对于像我这样的Mac用户，有一些陷阱：

您无法保存到任何目录。他们中只有少数人可以接收您保存的文件。那里有更多信息

这是一个工作脚本，您可以在Mac的excel中复制粘贴：

1
2
3
4
5
6
7
8
9
10
11
12

Public Sub SaveWorksheetsAsCsv()

Dim WS As Excel.Worksheet
Dim SaveToDirectory As String

SaveToDirectory ="~/Library/Containers/com.microsoft.Excel/Data/"

For Each WS In ThisWorkbook.Worksheet
WS.SaveAs SaveToDirectory & WS.Name &".csv", xlCSV
Next

End Sub

请仔细阅读冯·波基(Von Pookie)的回答，所有分数均归功于他/她。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

Sub asdf()
Dim ws As Worksheet, newWb As Workbook

Application.ScreenUpdating = False
For Each ws In Sheets(Array("EID Upload","Wages with Locals Upload","Wages without Local Upload"))
ws.Copy
Set newWb = ActiveWorkbook
With newWb
.SaveAs ws.Name, xlCSV
.Close (False)
End With
Next ws
Application.ScreenUpdating = True

End Sub