Vba 将多个工作簿中的工作表复制到其他工作簿中的现有工作表中

我有一个模板工作簿，其选项卡名为“Extract 1、Extract 2、Extract 3”等，还有一个主摘要页面，其中包含依赖于所有这些选项卡的公式。我还有许多工作手册（22），每本都包含一个工作表，其中包含数据摘录。我需要能够循环浏览这些工作簿并复制工作表，而无需删除和插入新选项卡（需要使用现有选项卡）。最初，我有这样的想法：

    Sub GetSheets()
Path = "C:\Users\hill\Desktop\Summary Doc Output Files\Summary Doc Output Files\"
Filename = Dir(Path & "*.xls")
  Do While Filename <> ""
  Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
     For Each Sheet In ActiveWorkbook.Sheets
     Sheet.Copy After:=ThisWorkbook.Sheets(1)
  Next Sheet
     Workbooks(Filename).Close
     Filename = Dir()
  Loop
 Dim x As Integer

End Sub

Sub-GetSheets（）
Path=“C:\Users\hill\Desktop\Summary Doc Output Files\Summary Doc Output Files\”
Filename=Dir（路径&“*.xls”）
文件名“”时执行此操作
工作簿。打开文件名：=路径和文件名，只读：=真
对于ActiveWorkbook.Sheets中的每个工作表
Sheet.Copy After:=此工作簿.Sheets（1）
下一页
工作簿（文件名）。关闭
Filename=Dir（）
环
作为整数的Dim x
端接头

但这只会插入新选项卡，而不会使用现有的选项卡结构

---

有没有一种简单的方法可以做到这一点？

因为22本工作簿只有一张工作表，所以您不需要在每一张工作表之间循环。此外，您可以将工作表的内容复制到Mainbook中所需的任何工作表上

因此，替换

  For Each Sheet In ActiveWorkbook.Sheets
     Sheet.Copy After:=ThisWorkbook.Sheets(1)
  Next Sheet

与

注意：使用

.UsedRange

假定每个工作表中的数据结构与

提取

工作表中的数据结构相同，并且没有合并的单元格

假设您将第一个工作簿复制到

Extract 1

工作表，依此类推，您可以在宏中放置一个计数器，将每个工作簿粘贴到不同的工作表中

Sub GetSheets()
Dim x As Integer, wb as Workbook

Path = "C:\Users\hill\Desktop\Summary Doc Output Files\Summary Doc Output Files\"

Filename = Dir(Path & "*.xls")

x = 1
Do While Filename <> ""

    Set wb = Workbooks.Open Filename:=Path & Filename, ReadOnly:=True

    ThisWorkbook.Sheets("Extract " & x).UsedRange.Value = wb.Sheets(1).UsedRange.Value    

    wb.Close false

    x = x + 1

    Filename = Dir()

Loop


End Sub

Sub-GetSheets（）
Dim x为整数，wb为工作簿
Path=“C:\Users\hill\Desktop\Summary Doc Output Files\Summary Doc Output Files\”
Filename=Dir（路径&“*.xls”）
x=1
文件名“”时执行此操作
设置wb=工作簿。打开文件名：=路径和文件名，只读：=真
ThisWorkbook.Sheets（“Extract”&x）.UsedRange.Value=wb.Sheets（1）.UsedRange.Value
wb.关闭错误
x=x+1
Filename=Dir（）
环
端接头

Sub GetSheets()
Dim x As Integer, wb as Workbook

Path = "C:\Users\hill\Desktop\Summary Doc Output Files\Summary Doc Output Files\"

Filename = Dir(Path & "*.xls")

x = 1
Do While Filename <> ""

    Set wb = Workbooks.Open Filename:=Path & Filename, ReadOnly:=True

    ThisWorkbook.Sheets("Extract " & x).UsedRange.Value = wb.Sheets(1).UsedRange.Value    

    wb.Close false

    x = x + 1

    Filename = Dir()

Loop


End Sub