用VBA按列信息拆分数据到多张工作表

本文为随书问题参考答案

在本问题中，要将拆分结果保存在新工作簿中，那可以在执行拆分数据的操作前，先新建工作簿及工作表来保存拆分结果。

在写过程前，可以在模块的开始位置先声明两个模块级变量或公共变量：表示保存拆分结果的工作簿ToWb和要拆分的数据表Sht，如：

Dim ToWb As Workbook, Sht As Worksheet

然后将新建保存结果的工作簿及工作表的代码写为单独的过程，如：

Sub ShtAdd()
Dim ShtCount As Integer '记录新建工作簿中包含的工作表数量
Set ToWb = Workbooks.Add '新建工作簿，并存到变量ToWb中
ShtCount = ToWb.Worksheets.Count
Dim i As Long, ShtName As String
i = 2
'Do循环语句用于在工作簿中新建保存拆分结果的工作表
Do While Sht.Cells(i, "A").Value <> ""
ShtName = Sht.Cells(i, "A").Value
If IsSht(ShtName) = False Then 'IF语句判断指定名称的工作表是否存在
ToWb.Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = ShtName
Sht.Rows(1).Copy ToWb.Worksheets(ShtName).Rows(1) '复制表头到新工作表中
End If
i = i + 1
Loop
'For循环语句删除新建的工作簿中原带的空工作表
Application.DisplayAlerts = False
For i = ShtCount To 1 Step -1
ToWb.Worksheets(i).Delete
Next i
Application.DisplayAlerts = True
End Sub

其中用到一个判断指定名称的工作表是否存在的自定义函数，代码为：

Function IsSht(ByVal ShtName As String) As Boolean '判断工作表名称是否存在
On Error Resume Next
If Worksheets(ShtName) Is Nothing Then
IsSht = False '工作表不存在，函数值为False
Else
IsSht = True '工作表已存在，函数值为true
End If
End Function

当然，这个判断工作表是否存在的代码，也可以直接写在过程中。

最后，再在原有程中，在执行拆分数据的操作前先调用上面的子过程ShtAdd，就能解决这个问题了，如：

Sub 拆分数据到工作表()
Dim ShtName As String, ToRng As Range, i As Integer, DataArr As Variant
Set Sht = ActiveSheet
Call ShtAdd ' 调用子过程，新建保存拆分结果的工作表及工作表
i = 2 '要拆分的第一条数据的行号
Do While Sht.Cells(i, "A").Value <> ""
ShtName = Sht.Cells(i, "A").Value
Set ToRng = ToWb.Worksheets(ShtName).Range("A1048576").End(xlUp).Offset(1, 0)
DataArr = Sht.Cells(i, "A").Resize(1, 8).Value
ToRng.Resize(1, 8).Value = DataArr '用数组传递数据
i = i + 1 '重设变量的值，以便下次循环能拆分新的记录
Loop
End Sub

代码容器中完成后的代码截图如下：

执行“拆分数据到工作表”的过程，就能工作表中的数据，按A列的信息拆分到不同工作表，保存在新工作簿中了。