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

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

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

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

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 = TrueEnd 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 IfEnd 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 '重设变量的值，以便下次循环能拆分新的记录 LoopEnd Sub

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

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

版权声明：本文内容由网络用户投稿，版权归原作者所有，本站不拥有其著作权，亦不承担相应法律责任。如果您发现本站中有涉嫌抄袭或描述失实的内容，请联系我们jiasou666@gmail.com 处理，核实后本网站将在24小时内删除侵权内容。