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

Copying worksheets from multiple workbooks into current workbook

提问by user3430194

Copying worksheets from multiple workbooks into current workbook

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

Hi I was wondering if anybody if you guys could help me out?

嗨，我想知道是否有人可以帮助我？

Im trying to copy multiple workbooks and just save it into only one worksheet. I have 2000 diffrent workbooks with the diffrent amount of rows, The ammount of cells is the same and it dosent change and they are all at the first sheet in every workbook.

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

Im new with this kind of stuff so i'm thankfull for all help u can offer, I cant make it work. I'm using excel 2010

我是新来的，所以我很感激你能提供的所有帮助，我不能让它工作。我正在使用 excel 2010

This is what I got atm:

这是我得到的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 

采纳答案by Dan Wagner

Try this out:

试试这个：

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

回答by L42

I've re-written your code by applying what I posted in the comment.
Try this out: (I stick with your logic using the DIR function)

我通过应用我在评论中发布的内容重新编写了您的代码。
试试这个：（我坚持使用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

I've commented the code to help you modify it to suit your needs.
I you got stuck again, then just go back here and clearly state your problem.

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