Note: The other languages of the website are Google-translated. Back to English

如何遍歷目錄中的文件並將數據複製到Excel中的主表中?

假設一個文件夾中有多個Excel工作簿,並且您想循環瀏覽所有這些Excel文件,並將數據從指定範圍的同名工作表中復製到Excel中的主工作表中,該怎麼辦? 本文詳細介紹了一種實現方法。

循環瀏覽目錄中的文件,然後使用VBA代碼將數據複製到主表中


循環瀏覽目錄中的文件,然後使用VBA代碼將數據複製到主表中

如果要將範圍A1:D4中的指定數據從某個文件夾中的所有工作簿工作表1複製到母版工作表,請執行以下操作。

1.在工作簿中,您將創建一個主工作表,然後按 其他 + F11 鍵打開 Microsoft Visual Basic for Applications 窗口。

2。 在裡面 Microsoft Visual Basic for Applications 窗口中,單擊 插入 > 模塊。 然後將下面的VBA代碼複製到代碼窗口中。

VBA代碼:循環瀏覽文件夾中的文件並將數據複製到主表中

Sub Merge2MultiSheets()
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook, xWorkBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    xSheetName = "Sheet1"
    xRgStr = "A1:D4"
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            Set xWorkBook = ThisWorkbook
            Set xSheet = xWorkBook.Sheets("New Sheet")
            If xSheet Is Nothing Then
                xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "New Sheet"
                Set xSheet = xWorkBook.Sheets("New Sheet")
            End If
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            Do Until xFileName = ""
               Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
                Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
                xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

備註:

1)。 在代碼中,“A1:D4“和”Sheet1”表示將所有Sheet1的A4:D1範圍內的數據複製到主表中。 還有“新表”是新創建的母版表的名稱。
2)。 特定文件夾中的Excel文件不應打開。

3。 按 F5 鍵來運行代碼。

4.在開幕 瀏覽 窗口,請選擇包含您要循環瀏覽的文件的文件夾,然後單擊 OK 按鈕。 看截圖:

然後,在當前工作簿的末尾創建一個名為“ New Sheet”的主工作表。 工作表中列出了所選文件夾中所有Sheet1的A4:D1範圍內的數據。


相關文章:


最佳辦公效率工具

Kutools for Excel 解決了你的大部分問題,並將你的生產力提高了 80%

  • 重用: 快速插入 複雜的公式,圖表 以及您以前使用過的任何東西; 加密單元 帶密碼 創建郵件列表 並發送電子郵件...
  • 超級公式欄 (輕鬆編輯多行文本和公式); 閱讀版式 (輕鬆讀取和編輯大量單元格); 粘貼到過濾範圍...
  • 合併單元格/行/列 不會丟失數據; 拆分單元格內容; 合併重複的行/列...防止細胞重複; 比較範圍...
  • 選擇重複或唯一 行; 選擇空白行 (所有單元格都是空的); 超級查找和模糊查找 在許多工作簿中; 隨機選擇...
  • 確切的副本 多個單元格,無需更改公式參考; 自動創建參考 到多張紙; 插入項目符號,複選框等...
  • 提取文字,添加文本,按位置刪除, 刪除空間; 創建和打印分頁小計; 在單元格內容和註釋之間轉換...
  • 超級濾鏡 (將過濾方案保存並應用於其他工作表); 高級排序 按月/週/日,頻率及更多; 特殊過濾器 用粗體,斜體...
  • 結合工作簿和工作表; 根據關鍵列合併表; 將數據分割成多個工作表; 批量轉換xls,xlsx和PDF...
  • 超過 300 項強大的功能. 支持 Office / Excel 2007-2021 和 365。支持所有語言。 在您的企業或組織中輕鬆部署。 完整功能 30 天免費試用。 60 天退款保證。
kte選項卡201905

Office選項卡為Office帶來了選項卡式界面,使您的工作更加輕鬆

  • 在Word,Excel,PowerPoint中啟用選項卡式編輯和閱讀,發布者,Access,Visio和Project。
  • 在同一窗口的新選項卡中而不是在新窗口中打開並創建多個文檔。
  • 將您的工作效率提高 50%,每天為您減少數百次鼠標點擊!
officetab底部
按評論排序
留言 (20)
還沒有評分。 成為第一位評論!
網站主持人對此評論進行了最小化
謝謝你的vba代碼! 它完美地工作! 如果我需要粘貼為值,想知道代碼是什麼? 提前謝謝!
網站主持人對此評論進行了最小化
嗨來玲,
以下代碼可以幫助您解決問題。 感謝您的評論。

子 Merge2MultiSheets()
將 xRg 調暗為範圍
將 xSelItem 調暗為變體
將 xFileDlg 調暗為 FileDialog
將 xFileName、xSheetName、xRgStr 作為字符串調暗
暗淡 xBook,xWorkBook 作為工作簿
將 xSheet 調暗為工作表
在錯誤恢復下一頁
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName =“ Sheet1”
xRgStr = "A1:D4"
設置 xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
使用 xFileDlg
如果 .Show = -1 那麼
xSelItem = .SelectedItems.Item(1)
設置 xWorkBook = ThisWorkbook
設置 xSheet = xWorkBook.Sheets("新工作表")
如果 xSheet 什麼都不是,那麼
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "新工作表"
設置 xSheet = xWorkBook.Sheets("新工作表")
如果結束
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
If xFileName = "" Then Exit Sub
直到 xFileName = ""
設置 xBook = Workbooks.Open(xSelItem & "\" & xFileName)
設置 xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = 目錄()
xBook.關閉
循環
如果結束
結束
設置 xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
END SUB
網站主持人對此評論進行了最小化
嗨,謝謝你的代碼。 請讓我知道如何包含從中復制數據范圍的 Excel 文件名? 這將是一個很大的幫助!

謝謝。
網站主持人對此評論進行了最小化
你好,

感謝您的指導。

我將如何:僅複製“Sheet1”中包含“total”行中的值的行,並在名為“New Sheet”的主工作表中粘貼[filename]。 注意每個工作表中的總計行可能不同。

例如:
文件 1:工作表 1
Col1、Col2、Colx
1,2,15
結果,10,50

文件 2:工作表 1
Col1、Col2、Colx
1,5,10
2,4,16
3,3,6
4,5,6
5,7,10
結果,300,500

MasterFile:“新工作表”:
文件 1、10、50
文件 2、300、500
網站主持人對此評論進行了最小化
嗨,這很好用。 有沒有辦法改變只是拉出值而不是公式?
謝謝!!
網站主持人對此評論進行了最小化
嗨Trish,
以下代碼可以幫助您解決問題。 感謝您的評論。

子 Merge2MultiSheets()
將 xRg 調暗為範圍
將 xSelItem 調暗為變體
將 xFileDlg 調暗為 FileDialog
將 xFileName、xSheetName、xRgStr 作為字符串調暗
暗淡 xBook,xWorkBook 作為工作簿
將 xSheet 調暗為工作表
在錯誤恢復下一頁
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName =“ Sheet1”
xRgStr = "A1:D4"
設置 xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
使用 xFileDlg
如果 .Show = -1 那麼
xSelItem = .SelectedItems.Item(1)
設置 xWorkBook = ThisWorkbook
設置 xSheet = xWorkBook.Sheets("新工作表")
如果 xSheet 什麼都不是,那麼
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "新工作表"
設置 xSheet = xWorkBook.Sheets("新工作表")
如果結束
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
If xFileName = "" Then Exit Sub
直到 xFileName = ""
設置 xBook = Workbooks.Open(xSelItem & "\" & xFileName)
設置 xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = 目錄()
xBook.關閉
循環
如果結束
結束
設置 xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
END SUB
網站主持人對此評論進行了最小化
嗨,它仍在提取公式,而不是值,所以它給了我一個#REF 錯誤。 我知道它可能在某個地方需要一個 .PasteSpecial xlPasteValues,但我不知道在哪裡。 你能幫我嗎? 謝謝!
網站主持人對此評論進行了最小化
嗨,謝謝。


如何包含代碼以遍歷所有文件夾和子文件夾並執行上述複製?


謝謝!
網站主持人對此評論進行了最小化
嗨 - 這段代碼非常適合我想要實現的目標。

有沒有辦法遍歷所有文件夾和子文件夾並執行複制?


謝謝!
網站主持人對此評論進行了最小化
嗨 - 此代碼適用於每個文件的前 565 行,但之後的所有行都與下一個文件重疊。
有沒有辦法解決這個問題?
網站主持人對此評論進行了最小化
謝謝-如何將工作簿中的每個工作表中的(特殊值)複製並粘貼到主主文件中的單獨工作表中?
網站主持人對此評論進行了最小化
如果單元格為空,如何讓代碼留空?
網站主持人對此評論進行了最小化
對我來說,我的每個文件的“Sheet1”選項卡名稱都會更改。 例如,Tab1、Tab2、Tab3、Tab4 ......如何設置循環以遍歷 excel 中的列表並不斷更改“Sheet1”名稱,直到它遍歷所有內容?
網站主持人對此評論進行了最小化
嗨尼克,下面的 VBA 代碼可以幫助您解決問題。 請試一試。 子循環通過文件重命名()
'由擴展辦公室更新 2021/12/31
將 xRg 調暗為範圍
將 xSelItem 調暗為變體
將 xFileDlg 調暗為 FileDialog
將 xFileName、xSheetName、xRgStr 作為字符串調暗
暗淡 xBook,xWorkBook 作為工作簿
將 xSheet 調暗為工作表
將 xShs 調暗為工作表
將 xName 調暗為字符串
將 xFNum 調暗為整數
在錯誤恢復下一頁
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
設置 xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xFileDlg.顯示
xSelItem = xFileDlg.SelectedItems.Item(1)
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
當 xFileName <> ""
設置 xWorkBook = Workbooks.Open(xSelItem & "\" & xFileName)
設置 xShs = xWorkBook.Sheets
對於 xFNum = 1 到 xShs.Count
設置 xSheet = xShs.Item(xFNum)
xName = xSheet.Name
xName = 替換(xName,““”標籤") '用標籤替換工作表
xSheet.Name = xName
下一頁
xWorkBook.保存
xWorkBook.關閉
xFileName = 目錄()
循環
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
END SUB
網站主持人對此評論進行了最小化
嗨,我想要一個代碼將 6 個不同工作簿(在一個文件夾中)中的數據複製到新工作簿中,其中包含工作表。 在 vba 中
請幫我asp
網站主持人對此評論進行了最小化
嗨帕拉努沙,
以下文章中的 VBA 腳本可以將多個工作簿或指定的工作簿表組合成一個主工作簿。 請檢查它是否有幫助。
如何在 Excel 中將多個工作簿合併為一個主工作簿?
網站主持人對此評論進行了最小化
Olá bom dia。
Gostei muito dessde código, mas não me ajudou com os relatórios que eu preciso impreimir。
Preciso imprimir 2.400 relatório de exel que estão em Pastas diferentes e não estão configuradas corretamente para impressão。 Pode me enviar um códgo de VBA que automatize essas impressões ? 我 ajudaria muito,obrigada。
網站主持人對此評論進行了最小化
嗨瑪麗亞蘇亞雷斯,
請檢查以下帖子中的 VBA 代碼是否有幫助。
如何在Excel中打印多個工作簿?
網站主持人對此評論進行了最小化
我的情況是相似的,除了我在每個文件中有多個工作表,所有工作表都具有不同的名稱但文件之間是一致的。 有沒有辦法循環此代碼以復製文件中的數據並將(值)粘貼到主工作簿中的特定工作表名稱? 母版中的工作表名稱與文件中的相同。 我想遍歷它們。 此外,每張工作表中的數據量會有所不同,因此我需要使用如下方式選擇每張工作表中的數據:

範圍(“A1”)。選擇
範圍(選擇,選擇。結束(xlDown))。選擇
範圍(選擇,選擇。結束(xlToRight))。選擇


文件表名稱為 Giving、Services、Insurance、Car、Other Expenses 等...

在此先感謝。
網站主持人對此評論進行了最小化
嗨,安德魯·沙漢,
以下 VBA 代碼可以解決您的問題。 運行代碼並選擇文件夾後,代碼會自動按名稱匹配工作表並將數據粘貼到主工作簿中的同名工作表中。
Sub Merge2MultiSheets()
'Updated by Extendoffice 20221209
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook As Workbook, xMainBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set xMainBook = ThisWorkbook
    
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            
            Do Until xFileName = ""
            Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)

            For Start = 1 To xBook.Worksheets.Count
                Set xSheet = xBook.Worksheets.Item(Start)
                xSheet.Activate
                xSheetName = xSheet.Name
                xSheet.UsedRange.Copy (xMainBook.Worksheets.Item(xSheetName).Range("A1048576").End(xlUp).Offset(1, 0))
            Next
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
這裡還沒有評論
留下你的意見
以訪客身份發帖
×
評價此帖子:
0   字符
推薦地點

關注我們

版權所有©2009 - 萬維網。extendoffice.com。 | 版權所有。 供電 ExtendOffice。 |
Microsoft和Office徽標是Microsoft Corporation在美國和/或其他國家的商標或註冊商標。
受Sectigo SSL保護