问：如何根据 Excel 中的列将数据拆分为多个 workbooks/files？
Q: How can I split data into multiple workbooks/files based on column in Excel?
我是 VBA 的新手，所以我希望我听起来不会太无知。每个月我都会收到一份报告，其中包含范围 A:T 和大约 7000-10000 行的数据。我需要将这些数据分成多个 workbooks/files 以便我可以将它们发送出去。
目前，我手动过滤列并将数据复制并粘贴到空白中 excel 并为每个名称另存为，但这效率极低。我完全不熟悉 VBA 或任何类型的代码，所以我一直在四处搜寻以找到可能有帮助的任何代码。我不确定我是否可以直接过滤数据并将它们保存到新的工作簿中，但我知道您可以将其作为工作表来完成。我已经接近使用此处的代码：https://www.excelhow.net/split-data-into-multiple-worksheets-based-on-column.html，如下所示，但我注意到工作表名称的字符限制导致了一些问题。
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.
Application.ScreenUpdating = False
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="3", Type:=1)
Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
'Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
Application.ScreenUpdating = True
End Sub
我想知道是否有人可以帮助我根据名称列 (C) 或 bypass/avoid 工作表名称的字符限制将数据拆分为多个工作簿，将工作表另存为单独的工作簿并重命名他们以后？我发送的文件在标题中有名称（例如 NameXYZ_report），因此最好结果也根据该列命名。
问题总结：
- 直接根据名称（C列值，经常超过31个字符）将数据拆分到多个工作簿中，文件名为'Name_report0122'，同时保持header（第1行）
- 保持原始数据的列宽
编辑；如果不能直接保存为工作簿，是否可以将它们以缩写形式保存为工作表，将这些工作表保存为工作簿，然后再正确地批量重命名文件？
对于我的问题造成的任何困惑，我深表歉意，因为我是新手，但我想改进。谢谢大家！
将过滤后的数据导出到新工作簿
Option Explicit
Sub ExportToWorkbooks()
Const aibPrompt As String = "Which column would you like to filter by?"
Const aibtitle As String = "Filter Column"
Const aibDefault As Long = 3
Dim dFileExtension As String: dFileExtension = ".xlsx"
Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
Dim dFolderPath As String: dFolderPath = "C:\Test\"
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
If Len(Dir(dFolderPath, vbDirectory)) = 0 Then Exit Sub ' folder not found
If Left(dFileExtension, 1) <> "." Then dFileExtension = "." & dFileExtension
Application.ScreenUpdating = False
Dim sCol As Variant
sCol = Application.InputBox(aibPrompt, aibtitle, aibDefault, , , , , 1)
If Len(CStr(sCol)) = 0 Then Exit Sub ' no entry
If sCol = False Then Exit Sub ' canceled
Dim sws As Worksheet: Set sws = ActiveSheet
If sws.FilterMode Then sws.ShowAllData
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
If srCount < 3 Then Exit Sub ' not enough rows
Dim srrg As Range: Set srrg = srg.Rows(1) ' to copy column widths
Dim scrg As Range: Set scrg = srg.Columns(sCol)
Dim scData As Variant: scData = scrg.Value
' Write the unique values from the 1st column to a dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case insensitive
Dim Key As Variant
Dim r As Long
For r = 2 To srCount
Key = scData(r, 1)
If Not IsError(Key) Then ' exclude error values
If Len(Key) > 0 Then ' exclude blanks
dict(Key) = Empty
End If
End If
Next r
If dict.Count = 0 Then Exit Sub ' only error values and blanks
Erase scData
Dim dwb As Workbook
Dim dws As Worksheet
Dim dfcell As Range
Dim dFilePath As String
For Each Key In dict.Keys
' Add a new (destination) workbook and reference the first cell.
Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet
Set dws = dwb.Worksheets(1)
Set dfcell = dws.Range("A1")
' Copy/Paste
srrg.Copy
dfcell.PasteSpecial xlPasteColumnWidths
srg.AutoFilter sCol, Key
srg.SpecialCells(xlCellTypeVisible).Copy dfcell
sws.ShowAllData
dfcell.Select
' Save/Close
dFilePath = dFolderPath & Key & dFileExtension ' build the file path
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs dFilePath, xlOpenXMLWorkbook
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
Next Key
sws.AutoFilterMode = False
Application.ScreenUpdating = True
MsgBox "Data exported.", vbInformation
End Sub
我是 VBA 的新手，所以我希望我听起来不会太无知。每个月我都会收到一份报告，其中包含范围 A:T 和大约 7000-10000 行的数据。我需要将这些数据分成多个 workbooks/files 以便我可以将它们发送出去。
目前，我手动过滤列并将数据复制并粘贴到空白中 excel 并为每个名称另存为，但这效率极低。我完全不熟悉 VBA 或任何类型的代码，所以我一直在四处搜寻以找到可能有帮助的任何代码。我不确定我是否可以直接过滤数据并将它们保存到新的工作簿中，但我知道您可以将其作为工作表来完成。我已经接近使用此处的代码：https://www.excelhow.net/split-data-into-multiple-worksheets-based-on-column.html，如下所示，但我注意到工作表名称的字符限制导致了一些问题。
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.
Application.ScreenUpdating = False
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="3", Type:=1)
Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
'Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
Application.ScreenUpdating = True
End Sub
我想知道是否有人可以帮助我根据名称列 (C) 或 bypass/avoid 工作表名称的字符限制将数据拆分为多个工作簿，将工作表另存为单独的工作簿并重命名他们以后？我发送的文件在标题中有名称（例如 NameXYZ_report），因此最好结果也根据该列命名。
问题总结：
- 直接根据名称（C列值，经常超过31个字符）将数据拆分到多个工作簿中，文件名为'Name_report0122'，同时保持header（第1行）
- 保持原始数据的列宽
编辑；如果不能直接保存为工作簿，是否可以将它们以缩写形式保存为工作表，将这些工作表保存为工作簿，然后再正确地批量重命名文件？
对于我的问题造成的任何困惑，我深表歉意，因为我是新手，但我想改进。谢谢大家！
将过滤后的数据导出到新工作簿
Option Explicit
Sub ExportToWorkbooks()
Const aibPrompt As String = "Which column would you like to filter by?"
Const aibtitle As String = "Filter Column"
Const aibDefault As Long = 3
Dim dFileExtension As String: dFileExtension = ".xlsx"
Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
Dim dFolderPath As String: dFolderPath = "C:\Test\"
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
If Len(Dir(dFolderPath, vbDirectory)) = 0 Then Exit Sub ' folder not found
If Left(dFileExtension, 1) <> "." Then dFileExtension = "." & dFileExtension
Application.ScreenUpdating = False
Dim sCol As Variant
sCol = Application.InputBox(aibPrompt, aibtitle, aibDefault, , , , , 1)
If Len(CStr(sCol)) = 0 Then Exit Sub ' no entry
If sCol = False Then Exit Sub ' canceled
Dim sws As Worksheet: Set sws = ActiveSheet
If sws.FilterMode Then sws.ShowAllData
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
If srCount < 3 Then Exit Sub ' not enough rows
Dim srrg As Range: Set srrg = srg.Rows(1) ' to copy column widths
Dim scrg As Range: Set scrg = srg.Columns(sCol)
Dim scData As Variant: scData = scrg.Value
' Write the unique values from the 1st column to a dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case insensitive
Dim Key As Variant
Dim r As Long
For r = 2 To srCount
Key = scData(r, 1)
If Not IsError(Key) Then ' exclude error values
If Len(Key) > 0 Then ' exclude blanks
dict(Key) = Empty
End If
End If
Next r
If dict.Count = 0 Then Exit Sub ' only error values and blanks
Erase scData
Dim dwb As Workbook
Dim dws As Worksheet
Dim dfcell As Range
Dim dFilePath As String
For Each Key In dict.Keys
' Add a new (destination) workbook and reference the first cell.
Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet
Set dws = dwb.Worksheets(1)
Set dfcell = dws.Range("A1")
' Copy/Paste
srrg.Copy
dfcell.PasteSpecial xlPasteColumnWidths
srg.AutoFilter sCol, Key
srg.SpecialCells(xlCellTypeVisible).Copy dfcell
sws.ShowAllData
dfcell.Select
' Save/Close
dFilePath = dFolderPath & Key & dFileExtension ' build the file path
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs dFilePath, xlOpenXMLWorkbook
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
Next Key
sws.AutoFilterMode = False
Application.ScreenUpdating = True
MsgBox "Data exported.", vbInformation
End Sub