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

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

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

Dim ToWb As Workbook, Sht As WorksheetSub 拆分数据到工作簿() 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 SubPrivate 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 FalseEnd SubPrivate 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 FunctionPrivate 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

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

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