將指定文件夾中所有工作簿里的數據合并到同一工作表中

將指定文件夾中所有工作簿里的數據合并到同一工作表中

本文為《別怕，Excel VBA其實很簡單（第3版）》隨書問題參-

如果要合并數據的工作簿保存在代碼所在目錄下，名為“我的文件”的文件夾中，要合并這些文件中第一張工作表的數據，可以用下面的過程：

Sub 合并多工作簿第一張表的數據() Application.ScreenUpdating = False Dim DataArr As Variant, DataWb As Workbook, DataSht As Worksheet Dim EndRow As Long, ToSht As Worksheet, ToRng As Range Dim FileName As String '要合并的工作簿名稱 Dim a As Long, b As Long Set ToSht = ThisWorkbook.Worksheets(1) ToSht.Rows("2:1048576").Clear '清除原有數據 FileName = Dir(ThisWorkbook.Path & "\我的文件\*.xls?") Do While FileName <> "" Workbooks.Open FileName:=ThisWorkbook.Path & "\我的文件\" & FileName Set DataWb = ActiveWorkbook Set DataSht = DataWb.Worksheets(1) EndRow = DataSht.Range("A1048576").End(xlUp).Row DataArr = DataSht.Range("A2").Resize(EndRow - 1, 8).Value Set ToRng = ToSht.Range("A1048576").End(xlUp).Offset(1, 0) For a = 1 To UBound(DataArr, 1) '將數組中超過15位的數字轉為文本 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(UBound(DataArr, 1), 8).Value = DataArr DataWb.Close savechanges:=False FileName = Dir Loop Application.ScreenUpdating = True MsgBox "合并完成！"End Sub

如果工作簿中保存了多張工作表，要合并所有工作表中的數據，過程可以改寫為：

Sub 合并多工作簿所有工作表的數據() Application.ScreenUpdating = False Dim DataArr As Variant, DataWb As Workbook, DataSht As Worksheet Dim EndRow As Long, ToSht As Worksheet, ToRng As Range Dim FileName As String '要合并的工作簿名稱 Dim a As Long, b As Long Set ToSht = ThisWorkbook.Worksheets(1) ToSht.Rows("2:1048576").Clear '清除原有數據 FileName = Dir(ThisWorkbook.Path & "\我的文件\*.xls?") Do While FileName <> "" Workbooks.Open FileName:=ThisWorkbook.Path & "\我的文件\" & FileName Set DataWb = ActiveWorkbook For Each DataSht In DataWb.Worksheets EndRow = DataSht.Range("A1048576").End(xlUp).Row DataArr = DataSht.Range("A2").Resize(EndRow - 1, 8).Value Set ToRng = ToSht.Range("A1048576").End(xlUp).Offset(1, 0) For a = 1 To UBound(DataArr, 1) '將數組中超過15位的數字轉為文本 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(UBound(DataArr, 1), 8).Value = DataArr Next DataSht DataWb.Close savechanges:=False FileName = Dir Loop Application.ScreenUpdating = True MsgBox "合并完成！"End Sub

你發現第二個過程在第一個過程的基礎上，改動了哪些地方嗎？

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

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