用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小時內刪除侵權內容。

版權聲明：本文內容由網絡用戶投稿，版權歸原作者所有，本站不擁有其著作權，亦不承擔相應法律責任。如果您發現本站中有涉嫌抄襲或描述失實的內容，請聯系我們jiasou666@gmail.com 處理，核實后本網站將在24小時內刪除侵權內容。