VBA035-多字段拆分工作表为工作簿

摘要：每个新工作簿包含对应字段组合的所有行数据命名格式为"E列值-C列值.xlsx"在桌面创建当天日期格式(YYYY-MM-DD)的文件夹所有新工作簿保存后自动关闭处理特殊字符和长文件名情况Sub SplitDataByColumnsEC'变量声明Dim ws As

根据表格中的字段，将工作表拆分为工作簿。主字段为E列，次字段为C列。新工作簿命名为E列-C列，新工作簿保存路径：在桌面新建一个命名为当天日期的文件夹，将新工作簿全部关闭并保存到该路径下。

用户需要根据Excel工作表中的E列(主字段)和C列(次字段)组合值将数据拆分到不同工作簿，具体要求：

每个新工作簿包含对应字段组合的所有行数据命名格式为"E列值-C列值.xlsx"在桌面创建当天日期格式(YYYY-MM-DD)的文件夹所有新工作簿保存后自动关闭处理特殊字符和长文件名情况Sub SplitDataByColumnsEC'变量声明Dim ws As Worksheet, newWb As Workbook, originalActiveWB As WorkbookDim dict As Object, uniquecombinations As CollectionDim dataRange As Range, visibleData As RangeDim savePath As String, dateFolder As StringDim eValue As String, cValue As String'保存原始工作簿引用Set originalActiveWB = ActiveWorkbook'错误处理On Error GoTo ErrorHandler'=== 数据准备阶段 ===Set ws = originalActiveWB.ActiveSheetlastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).RowSet dataRange = ws.Range("A1").CurrentRegion'收集唯一值组合Set dict = CreateObject("Scripting.Dictionary")Set uniqueCombinations = New CollectionFor i = 2 To lastRoweValue = CStr(ws.Cells(i, "E").Value)cValue = CStr(ws.Cells(i, "C").Value)If eValue > "" And cValue > "" Thenkey = eValue & "|" & cValueIf Not dict.exists(key) Thendict.Add key, Array(eValue, cValue)uniqueCombinations.Add Array(eValue, cValue)End IfEnd IfNext i'=== 文件处理阶段 ===dateFolder = Format(Date, "YYYY-MM-DD")savePath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & dateFolder & "\"If Dir(savePath, vbDirectory) = "" Then MkDir savePathApplication.ScreenUpdating = FalseApplication.DisplayAlerts = False'=== 主处理循环 ===For Each combination In uniqueCombinationseValue = CStr(combination(0))cValue = CStr(combination(1))'确保在原工作簿操作originalActiveWB.Activatews.AutoFilterMode = Falsews.Rows(1).Copy'创建新工作簿Set newWb = Workbooks.AddnewWb.Sheets(1).PasteApplication.CutCopyMode = False'返回原工作簿筛选数据originalActiveWB.ActivatedataRange.AutoFilter Field:=5, Criteria1:=eValue 'E列dataRange.AutoFilter Field:=3, Criteria1:=cValue 'C列'复制可见数据On Error Resume NextSet visibleData = dataRange.Offset(1, 0).Resize(dataRange.Rows.Count - 1).SpecialCells(xlCellTypeVisible)If Not visibleData Is Nothing ThenvisibleData.Copy newWb.Sheets(1).Cells(2, 1)End If'保存新工作簿newWb.SaveAs savePath & CleanFileName(eValue) & "-" & CleanFileName(cValue) & ".xlsx", FileFormat:=xlOpenXMLWorkbooknewWb.Close FalseNext combinationCleanUp:'=== 清理阶段 ===ws.AutoFilterMode = FalseoriginalActiveWB.ActivateApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueMsgBox "成功拆分 " & uniqueCombinations.Count & " 个工作簿到：" & vbCrLf & savePath, vbInformationExit SubErrorHandler:'错误处理MsgBox "错误 " & Err.Number & ": " & Err.Description & vbCrLf & "操作已中断", vbCriticalResume CleanUpEnd SubFunction CleanFileName(strName As String) As String'清理非法字符Dim illegalChars As String: illegalChars = "\/:*?""|"For i = 1 To Len(illegalChars)strName = Replace(strName, Mid(illegalChars, i, 1), "_")NextCleanFileName = Left(strName, 31) '限制文件名长度End Function

将全年销售数据按"月份-区域"组合拆分为独立文件，便于分发给各区域经理。

适配方法：修改E列和C列的引用为月份和区域列，调整文件名格式为"区域-月份报表.xlsx"

将产品库存表按"产品大类-子类"组合拆分，自动创建分类归档。

将全校成绩表按"年级-班级"拆分，生成各班成绩单。

拆分前数据源