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

本文为《别怕，Excel VBA其实很简单（第3版）》随书问题参考答案

Dim ToWb As Workbook, Sht As Worksheet
Sub 拆分数据到工作簿()
Application.ScreenUpdating = False
Dim ShtName As String, ToRng As Range, i As Integer, DataArr As Variant
Set Sht = ActiveSheet
Call ShtAdd ' 调用子过程，新建保存拆分结果的工作表及工作表
i = 2 '要拆分的第一条数据的行号
Dim a As Long, b As Long
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
For a = 1 To UBound(DataArr, 1)
For b = 1 To UBound(DataArr, 2)
If Len(DataArr(a, b)) > 15 Then
DataArr(a, b) = "'" & DataArr(a, b)
End If
Next b
Next a
ToRng.Resize(1, 8).Value = DataArr '用数组传递数据
i = i + 1 '重设变量的值，以便下次循环能拆分新的记录
Loop
Call ShtToWb(ToWb)
Application.ScreenUpdating = True
MsgBox "拆分完成!"
End Sub
Private Sub ShtToWb(ByVal Wb As Workbook)
Dim Sht As Worksheet
For Each Sht In Wb.Worksheets
Sht.Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Sht.Name & ".xlsx"
ActiveWorkbook.Close
Next Sht
Wb.Close False
End Sub
Private 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
Private 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

解决这个问题应该还有其他的思路，给出的示例代码也还有许多需要改进的地方，留给大家自由发挥了。