将多个工作簿中的多个工作表的数据复制到单个主工作簿中 [英] copy data from multiple worksheets in multiple workbooks, all into single master workbook

问题描述

我是新来的宏需要帮助。我在一个文件夹中几乎没有工作簿，每个工作簿有四个工作表。现在我想要一个从每个工作簿复制数据（工作表明智）并过去在我的主工作簿（工作表明智）中的mocro意味着sheet1的数据分别在sheet1和sheet2的主工作簿中粘贴在另一个之下。*工作簿名称可以是文件夹中的任何东西
任何人都可以帮我整个代码呢？
我有一个宏从一个工作表到我分配的工作表的数据，但从打印工作表复制粘贴数据只是不明白。
任何人都可以帮助我修改以下代码：

  Sub Ref_Doc_Collat​​ion（）
 Dim MyFile As String 
 Dim erow 
 Dim Filepath As String 
 Application.ScreenUpdating = False 
 Filepath =\\NAMDFS\TPA\MWD\USERS\ay86009\ Referral_Doc\
 MyFile = Dir（Filepath）
 Do While Len（MyFile）> 0 
如果MyFile =Referral_Doc_Collat​​ion.xlsm然后
退出Sub 
结束如果
 
 Workbooks.Open（Filepath& MyFile）
表格（分配）。范围（B2：L3000）。复制
 Application.DisplayAlerts = False 
 
 erow = Sheet1.Cells（Rows.Count，2）.End（xlUp）.Offset （1，0）.Row 
 ActiveSheet.Paste Destination：= Worksheets（Allocation）。Range（Cells（erow，2），Cells（erow，12））
 
 activeesheet。 next.select 
 
 Sheets（Prefetcher）。Range（B2：I3000）。复制
 Application.DisplayAlerts = False 
 
 erow = Sheet2.Cells （Rows.Count，2）.End（xlUp）.Offset（1，0）.Row 
 ActiveSheet.Paste Destination：= Worksheets（Prefetcher）。Range（Cells（erow，2），Cells ，9））
 
 activeesheet.next.select 
 
表格（Matrix）。范围（B2：G3000）。复制
 Application.DisplayAlerts = False 
 
 erow = Sheet3.Cells（Rows.Count，2）.End（xlUp）.Offset（1，0）.Row 
 ActiveSheet.Paste Destination：= Worksheets（Matrix ）.Range（Cells（erow，2），Cells（erow，7））
 
 acti vesheet.next.select 
 
表格（跟随）范围（B2：H3000）。复制
 Application.DisplayAlerts = False 
 
 erow = Sheet4.Cells（Rows.Count，2）.End（xlUp）.Offset（1，0）.Row 
 ActiveSheet.Paste Destination：= Worksheets（Follow ups）。Range（Cells（erow，2） ，Cells（erow，8））
 
 
 ActiveWorkbook.Close 
 MyFile = Dir 
 
循环
 Application.ScreenUpdating = True 
 MsgBoxDONE
 End Sub 
  

解决方案

编译但未测试：

  Sub Ref_Doc_Collat​​ion（）
 
 Const FILE_PATH As String =\ \NAMDFS\TPA\MWD\USERS\ay86009\Referral_Doc\
 Const SKIP_FILE As String =Referral_Doc_Collat​​ion.xlsm
 
 Dim MyFile As String，wb As工作簿
 
 Application.ScreenUpdating = False 
 
 MyFile = Dir（FILE_PATH）
 
 Do While Len（MyFile）> 0 
 
如果MyFile<> SKIP_FILE然后
 
设置wb = Workbooks.Open（FILE_PATH& MyFile）
 
 wb.Sheets（Allocation）。Range（B2：L3000）。 
 ThisWorkbook.Sheets（Allocation）。单元格（Rows.Count，B）。 _ 
 End（xlUp）.Offset（1，0）
 
 wb.Sheets（Prefetcher）。Range（B2：I3000）。复制_ 
 ThisWorkbook。表格（Prefetcher）。单元格（Rows.Count，B）。 _ 
 End（xlUp）.Offset（1，0）
 
 wb.Sheets（Matrix）。Range（B2：G3000）。复制_ 
 ThisWorkbook。表格（矩阵）。单元格（Rows.Count，B）。 _ 
 End（xlUp）.Offset（1，0）
 
 wb.Sheets（Follow ups）。范围（B2：H3000）复制_ 
 ThisWorkbook .Sheets（Allocation）。Cells（Rows.Count，B）。 _ 
 End（xlUp）.Offset（1，0）
 
 wb.Close False 
 
如果
 
 MyFile = Dir 
 
循环
 
 Application.ScreenUpdating = True 
 MsgBoxDONE
 
 End Sub 
  

I am new to macro and needs help. I have few workbooks in a folder and each workbook has four worksheets. now I want a mocro which copy data from each workbook (worksheet wise) and past in my master workbook (worksheet wise) means data of sheet1 shoud be pasted one below the other in my master workbook in sheet1 and sheet 2 respectively.*Workbook name could be anything in folder. Can anyone help me with entire code to do that? I have macro to colate data from one sheet to my assigned sheet but it copy paste data from open sheet only not by sheet name wise. Can anyone help to make corrections in my below code :

Sub Ref_Doc_Collation()
Dim MyFile As String
Dim erow
Dim Filepath As String
Application.ScreenUpdating = False
Filepath = "\\NAMDFS\TPA\MWD\USERS\ay86009\Referral_Doc\"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Referral_Doc_Collation.xlsm" Then
Exit Sub
End If

Workbooks.Open (Filepath & MyFile)
Sheets("Allocation").Range("B2:L3000").Copy
Application.DisplayAlerts = False

erow = Sheet1.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Allocation").Range(Cells(erow, 2), Cells(erow, 12))

activesheet.next.select

Sheets("Prefetcher").Range("B2:I3000").Copy
Application.DisplayAlerts = False

erow = Sheet2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Prefetcher").Range(Cells(erow, 2), Cells(erow, 9))

activesheet.next.select

Sheets("Matrix").Range("B2:G3000").Copy
Application.DisplayAlerts = False

erow = Sheet3.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Matrix").Range(Cells(erow, 2), Cells(erow, 7))

activesheet.next.select

Sheets("Follow ups").Range("B2:H3000").Copy
Application.DisplayAlerts = False

erow = Sheet4.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Follow ups").Range(Cells(erow, 2), Cells(erow, 8))


ActiveWorkbook.Close
MyFile = Dir

Loop
Application.ScreenUpdating = True
MsgBox "DONE"
End Sub

解决方案

Compiled but not tested:

Sub Ref_Doc_Collation()

    Const FILE_PATH As String = "\\NAMDFS\TPA\MWD\USERS\ay86009\Referral_Doc\"
    Const SKIP_FILE As String = "Referral_Doc_Collation.xlsm"

    Dim MyFile As String, wb As Workbook

    Application.ScreenUpdating = False

    MyFile = Dir(FILE_PATH)

    Do While Len(MyFile) > 0

        If MyFile <> SKIP_FILE Then

            Set wb = Workbooks.Open(FILE_PATH & MyFile)

            wb.Sheets("Allocation").Range("B2:L3000").Copy _
                ThisWorkbook.Sheets("Allocation").Cells(Rows.Count, "B"). _
                   End(xlUp).Offset(1, 0)

            wb.Sheets("Prefetcher").Range("B2:I3000").Copy _
                ThisWorkbook.Sheets("Prefetcher").Cells(Rows.Count, "B"). _
                   End(xlUp).Offset(1, 0)

            wb.Sheets("Matrix").Range("B2:G3000").Copy _
                ThisWorkbook.Sheets("Matrix").Cells(Rows.Count, "B"). _
                   End(xlUp).Offset(1, 0)

            wb.Sheets("Follow ups").Range("B2:H3000").Copy _
                ThisWorkbook.Sheets("Allocation").Cells(Rows.Count, "B"). _
                   End(xlUp).Offset(1, 0)

            wb.Close False

        End If

        MyFile = Dir

    Loop

    Application.ScreenUpdating = True
    MsgBox "DONE"

End Sub

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