- A+
所属分类：办公技巧
用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列的信息拆分到不同工作表，保存在新工作簿中了。
学习资料见知识星球。
以上就是今天要分享的技巧，你学会了吗？若有什么问题，欢迎在下方留言。
快来试试吧，小琥 my21ke007。获取 1000个免费 Excel模板福利！
更多技巧， www.excelbook.cn
欢迎 加入 零售创新 知识星球，知识星球主要以数据分析、报告分享、数据工具讨论为主；
你将获得：
1、价值上万元的专业的PPT报告模板。
2、专业案例分析和解读笔记。
3、实用的Excel、Word、PPT技巧。
4、VIP讨论群，共享资源。
5、优惠的会员商品。
6、一次付费只需99元，即可下载本站文章涉及的文件和软件。
- 我的微信
-
- 我的知识星球
-
