一类特殊Excel工作表拆分成多个工作表的解决方法

将已有的Excel工作表按一定的条件拆分成多张不同的工作表是日常进行Excel操作时做得比较多的工作。当原始表格数据量很大且平时要经常性地做这项工作，那么可以借助于一些工具软件或使用Excel内置的VBA宏代码来实现。

有一张Excel Report（如下图示），第一列是单号，现在要根据第一列的单号拆分多个独立的Excel表格，每个Excel文件以第一列的单号命名。比如第一列有50个单号，可以自动拆分成50个Excel文件，然后可以相应带出每个单号后面的信息，并以单号命名每个Excel文件。

分析这张Excel工作表可以发现，工作表的第1列是单号，每个订单包含多行数据，第1列中相同订单号的单元格以【合并单元格】形式呈现，那么如何用VBA宏来实现按订单号来拆分这张工作表，并将拆分后的数据按订单号单独存盘呢？

这个工作表拆分的关键是要确定各个订单的开始行与结束行的行号的确定，实际上与列数无关。为了问题描述简单清晰，这里制作如下图所示的一张Excel样表。

第一行为标题行，拆分后的每张子工作表都应该包含这一行。现在按Alt+F11进入VBA宏代码窗口，这里首先创建一个自定义函数split_range，用来确定各个订单的起始与结束行号，参数为工作表对象。

Function split_range(sh As Worksheet) As String '以订单号计算拆分地址 Dim usedRows As Long, splitAddr As String With sh usedRows = .UsedRange.Rows.Count r0 = 2 r = 2 Do While r <= usedRows r = r + 1 If (.Range("A" & r).Value <> "") And (.Range("A" & r).Value <> .Range("A" & r0)) Then splitAddr = splitAddr & "," & r0 & ":" & r - 1 r0 = r End If Loop splitAddr = splitAddr & "," & r0 & ":" & r - 1 End With split_range = Mid(splitAddr, 2)End Function

程序首先给出工作表已使用行数usedRows，然后以A列数据为分析标准，从第3行开始，用变量r0记住一个订单开始的行号，变量r从上到下逐个访问A列单元格，当指向的单元格不空且与r0所指的单元格内容不同时，表示新的订单开始，所以当前订单号的A列起止行地址为：r0:r-1，直至访问所有已使用行，函数将所有的地址段用逗号分隔构成一个字符串返回。

接下来再编写一个VBA宏CopyRowsToAnotherSheet，调用函数split_range，按给定的地址段来分拆工作表，并将分拆后的子工作表以订单号命名存盘。宏代码如下：

Sub CopyRowsToAnotherSheet() ' 定义源工作表和目标工作表 Dim wsSource As Worksheet, wsTarget As Worksheet Dim wb As Workbook, wbName As String Dim fd As FileDialog Dim folderPath As String On Error Resume Next Application.ScreenUpdating = False '禁止屏幕刷新 ' 设定拆分后工作簿存放的位置 Set fd = Application.FileDialog(msoFileDialogFolderPicker) With fd ' 显示对话框 .Show ' 检查是否选择了文件夹 If .SelectedItems.Count > 0 Then folderPath = .SelectedItems(1) ' 设置文件夹路径 Else MsgBox "您没有选择任何文件夹。" Exit Sub End If End With Application.StatusBar = "请稍等，正在处理数据..." ' 设置要拆分的工作表 Set wsSource = ActiveSheet 'ThisWorkbook.Sheets("拆分工作表") addr = split_range(wsSource) '计算拆分行地址 tmpAddr = Split(addr, ",") '拆分工作表，并另存为工作簿文件 For Each x In tmpAddr 'x为一个地址范围，用行号表示，如2:4 Workbooks.Add ‘新建工作簿 Set wb = ActiveWorkbook Set wsTarget = wb.Sheets(1) '复制标题行 wsSource.Range("1:1").Copy Destination:=wsTarget.Range("1:1") '复制数据行 wsSource.Range(x).Copy Destination:=wsTarget.Range("2:2") wbName = wsTarget.Range("A2").Value & ".xlsx" '工作簿名称 '保存工作簿 wb.SaveAs folderPath & "\" & wbName wb.Close Next Application.ScreenUpdating = True '开启屏幕刷新 Application.StatusBar = False MsgBox "操作完成!", vbInformation + vbOKOnly, "提示"End Sub

程序首先调用文件对话框Application.FileDialog指定分拆后的子文件存放的位置。接下来逐个创建新的工作簿，将源工作表中数据拷贝到新建工作簿的sheet1中。用 wsSource.Range("1:1").Copy Destination:=wsTarget.Range("1:1") 复制标题行，用wsSource.Range(x).Copy Destination:=wsTarget.Range("2:2") 复制数据行。代码具体的实现见注释。