将多个工作簿中的工作表复制到当前工作簿中

Posted 2023-02-23

【中文标题】将多个工作簿中的工作表复制到当前工作簿中

【英文标题】：Copying worksheets from multiple workbooks into current workbook

【发布时间】：2014-05-14 11:26:53

【问题描述】：

您好，请问有没有人可以帮帮我？

我试图复制多个工作簿并将其保存到一个工作表中。 我有 2000 个不同的工作簿，它们的行数不同，单元格的数量是相同的，并且会发生变化，它们都在每个工作簿的第一张纸上。

我是这种东西的新手，所以我很感谢你能提供的所有帮助，我无法让它发挥作用。我正在使用 excel 2010

这是我在 atm 得到的：

Sub LoopThroughDirectory()
    Dim MyFile As String 
    Dim erow 
    Dim Filepath As String 

    Filepath = “C:\test\” 
    MyFile = Dir("test\") 

    Do While Len(MyFile) > 0 
        If MyFile = "master.xlsm" Then
            Exit Sub 
        End If
        Range(Range("a1"), ActiveCell.SpecialCells(xlLastCell)).Select
        Selection.Name = "PivotData" 
        Workbooks.Open (Filepath & MyFile)
        Range("A2:AD20").Copy 
        ActiveWorkbook.Close 
        erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        ActiveSheet.Paste Destination:=Worksheets("sheet1").Range(Cells(erow, 1), Cells(erow, 1))
        MyFile = Dir 
    Loop End
Sub 

【问题讨论】：

嘿，到目前为止你尝试了什么？

这是我目前得到的.. Sub LoopThroughDirectory() Dim MyFile As String Dim erow Dim Filepath As String Filepath = “C:\test\” MyFile = Dir("test\") Do While Len(MyFile) > 0 If MyFile = "master.xlsm" Then Exit Sub End If Range(Range("a1"), ActiveCell.SpecialCells_(xlLastCell)).Select Selection.Name = "PivotData" Workbooks.Open ( Filepath & MyFile) Range("A2:AD20").Copy ActiveWorkbook.Close erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row ActiveSheet.Paste Destination:=Worksheets ("sheet1").Range(Cells(erow, 1), Cells(erow, 1)) MyFile = Dir Loop End Sub

这是一个很好的开始，很快就会有答案

您可以更新您的帖子以添加代码，而不是将其放在评论中。使用“代码” 按钮正确格式化。

我认为您的问题是正确限定变量。有关如何正确处理 Range Objects 的方法，请参阅 THIS，这也适用于其他对象。

【参考方案1】：

试试这个：

Option Explicit
Sub CombineDataFiles()

Dim DataBook As Workbook, OutBook As Workbook
Dim DataSheet As Worksheet, OutSheet As Worksheet
Dim TargetFiles As FileDialog
Dim MaxNumberFiles As Long, FileIdx As Long, _
    LastDataRow As Long, LastDataCol As Long, _
    HeaderRow As Long, LastOutRow As Long
Dim DataRng As Range, OutRng As Range

'initialize constants
MaxNumberFiles = 2001
HeaderRow = 1 'assume headers are always in row 1
LastOutRow = 1

'prompt user to select files
Set TargetFiles = Application.FileDialog(msoFileDialogOpen)
With TargetFiles
    .AllowMultiSelect = True
    .Title = "Multi-select target data files:"
    .ButtonName = ""
    .Filters.Clear
    .Filters.Add ".xlsx files", "*.xlsx"
    .Show
End With

'error trap - don't allow user to pick more than 2000 files
If TargetFiles.SelectedItems.Count > MaxNumberFiles Then
    MsgBox ("Too many files selected, please pick more than " & MaxNumberFiles & ". Exiting sub...")
    Exit Sub
End If

'set up the output workbook
Set OutBook = Workbooks.Add
Set OutSheet = OutBook.Sheets(1)

'loop through all files
For FileIdx = 1 To TargetFiles.SelectedItems.Count

    'open the file and assign the workbook/worksheet
    Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx))
    Set DataSheet = DataBook.ActiveSheet

    'identify row/column boundaries
    LastDataRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    LastDataCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

    'if this is the first go-round, include the header
    If FileIdx = 1 Then
        Set DataRng = Range(DataSheet.Cells(HeaderRow, 1), DataSheet.Cells(LastDataRow, LastDataCol))
        Set OutRng = Range(OutSheet.Cells(HeaderRow, 1), OutSheet.Cells(LastDataRow, LastDataCol))
    'if this is NOT the first go-round, then skip the header
    Else
        Set DataRng = Range(DataSheet.Cells(HeaderRow + 1, 1), DataSheet.Cells(LastDataRow, LastDataCol))
        Set OutRng = Range(OutSheet.Cells(LastOutRow + 1, 1), OutSheet.Cells(LastOutRow + 1 + LastDataRow, LastDataCol))
    End If

    'copy the data to the outbook
    DataRng.Copy OutRng

    'close the data book without saving
    DataBook.Close False

    'update the last outbook row
    LastOutRow = OutSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Next FileIdx

'let the user know we're done!
MsgBox ("Combined " & TargetFiles.SelectedItems.Count & " files!")

End Sub

【讨论】：

这非常有效，感谢你们的反馈！只是通过将2000更改为xxxxx来编辑文件数？谢谢你们！他们无论如何是为了让这个循环更快吗？我有一个战利品文件我必须这样做

嘿@user3430194，您可以通过将变量 MaxNumberFiles 更改为您想要的任何数字来编辑允许的最大文件。我不确定是否要进一步优化脚本以提高速度：循环本身非常快，但由于您的数据存在于许多地方，我认为瓶颈将是每个数据文件的打开/关闭

嘿@user3430194，脚本设置为多选，所以如果您导航到感兴趣的目录，您应该能够使用键盘快捷键ctrl + a选择所有文件

【参考方案2】：

我已通过应用我在评论中发布的内容重写了您的代码。 试试这个：（我坚持使用 DIR 函数的逻辑）

Sub test()

    Dim MyFile As String, MyFiles As String, FilePath As String
    Dim erow As Long
    '~~> Put additional variable declaration
    Dim wbMaster As Workbook, wbTemp As Workbook
    Dim wsMaster As Worksheet, wsTemp As Worksheet

    FilePath = "C:\test\"
    MyFiles = "C:\test\*.xlsx"
    MyFile = Dir(MyFiles)

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    '~~> Set your declared variables
    Set wbMaster = ThisWorkbook 'if you want to consolidate files in this workbook
    Set wsMaster = wbMaster.Sheets("Sheet1") 'replace Sheet1 to suit

    Do While Len(MyFile) > 0
        'Debug.Print MyFile
        If MyFile <> "master.xlsm" Then
            '~~> Open the file and at the same time, set your variable
            Set wbTemp = Workbooks.Open(Filename:=FilePath & MyFile, ReadOnly:=True)
            Set wsTemp = wbTemp.Sheets(1) 'I used index, you said there is only 1 sheet
            '~~> Now directly work on your object
            With wsMaster
                erow = .Range("A" & .Rows.Count).End(xlUp).Row 'get the last row
                '~~> Copy from the file you opened
                wsTemp.Range("A2:AD20").Copy 'you said this is fixed as well
                '~~> Paste on your master sheet
                .Range("A" & erow).Offset(1, 0).PasteSpecial xlPasteValues
            End With
            '~~> Close the opened file
            wbTemp.Close False 'set to false, because we opened it as read-only
            Set wsTemp = Nothing
            Set wbTemp = Nothing
        End If
        '~~> Load the new file
        MyFile = Dir
    Loop

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub

我已对代码进行了注释，以帮助您修改它以满足您的需要。 我你又卡住了，然后回到这里清楚地说明你的问题。

【讨论】：

嘿@L42，这是我会好好学习的好东西。感谢您的代码！

这个比以前的更好吗.. 抱歉，我还是处于这种工作的初学者水平..

顺便说一句，我能不能帮我解决一下我在 Dan wagner 之前的 commant 上留下的评论

@user3430194 我没有得到你的评论 :) 你需要什么帮助？