将工作表从多个工作簿复制到当前工作簿中 [英] Copying worksheets from multiple workbooks into current workbook

问题描述

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

Copying worksheets from multiple workbooks into current workbook

我想知道如果有人能帮助我吗？

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

我试图复制多个工作簿，并将其仅保存在一个工作表中。
我有2000个不同的工作簿与不同的行数，单元格的数量是相同的，它的剂量改变，他们都在每个工作簿的第一张表。

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.

我有新的这种东西，所以我很感谢所有的帮助，你可以提供，我不能让它的工作。我正在使用excel 2010

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

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

推荐答案

尝试这个：

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

这篇关于将工作表从多个工作簿复制到当前工作簿中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！