Excel Home
全球知名的Excel资源网站之一

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

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

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

在写过程前,可以在模块的开始位置先声明两个模块级变量或公共变量:表示保存拆分结果的工作簿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列的信息拆分到不同工作表,保存在新工作簿中了。

赞(15)
未经允许不得转载:ExcelHome » 用VBA按列信息拆分数据到多张工作表
分享到

关于我们联系我们
本站特聘法律顾问:李志群律师   沪ICP备11019229号-2

沪公网安备 31011702000001号

征信