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

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