如何在Excel VBA將指定文件夾中所有工作簿里的數(shù)據(jù)合并到同一工作表中
發(fā)布時(shí)間:2022-11-04 09:56 [ 我要自學(xué)網(wǎng)原創(chuàng) ] 發(fā)布人: 秋文-27173 閱讀: 4329

如果要合并數(shù)據(jù)的工作簿保存在代碼所在目錄下,名為“我的文件”的文件夾中,要合并這些文件中第一張工作表的數(shù)據(jù),可以用下面的過(guò)程:

Sub 合并多工作簿第一張表的數(shù)據(jù)()
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 '清除原有數(shù)據(jù)
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) '將數(shù)組中超過(guò)15位的數(shù)字轉(zhuǎn)為文本
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

如果工作簿中保存了多張工作表,要合并所有工作表中的數(shù)據(jù),過(guò)程可以改寫為:

Sub 合并多工作簿所有工作表的數(shù)據(jù)()
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 '清除原有數(shù)據(jù)
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) '將數(shù)組中超過(guò)15位的數(shù)字轉(zhuǎn)為文本
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

你發(fā)現(xiàn)第二個(gè)過(guò)程在第一個(gè)過(guò)程的基礎(chǔ)上,改動(dòng)了哪些地方嗎?

Excel VBA入門教程2020
我要自學(xué)網(wǎng)商城 ¥60 元
進(jìn)入購(gòu)買
文章評(píng)論
0 條評(píng)論 按熱度排序 按時(shí)間排序 /350
添加表情
遵守中華人民共和國(guó)的各項(xiàng)道德法規(guī),
承擔(dān)因您的行為而導(dǎo)致的法律責(zé)任,
本站有權(quán)保留或刪除有爭(zhēng)議評(píng)論。
參與本評(píng)論即表明您已經(jīng)閱讀并接受
上述條款。
V
特惠充值
聯(lián)系客服
APP下載
官方微信
返回頂部
分類選擇:
電腦辦公 平面設(shè)計(jì) 室內(nèi)設(shè)計(jì) 室外設(shè)計(jì) 機(jī)械設(shè)計(jì) 工業(yè)自動(dòng)化 影視動(dòng)畫 程序開發(fā) 網(wǎng)頁(yè)設(shè)計(jì) 會(huì)計(jì)課程 興趣成長(zhǎng) AIGC