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应用程序 窗口。

2。 在里面 Microsoft Visual Basic应用程序 窗口中,单击 插页 > 模块。 然后将下面的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 =真
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 =真
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 =真
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
这里还没有评论

关注我们

版权所有 © 2009 - extendoffice.com。 | 版权所有。 供电 ExtendOffice。 | 网站地图
Microsoft和Office徽标是Microsoft Corporation在美国和/或其他国家的商标或注册商标。
受Sectigo SSL保护