Question

我有一个模板工作簿，其标签名称为“Extract 1，Extract 2，Extract 3”等，还有一个主要的Summary页面，其中包含依赖所有这些选项卡的公式。我还有许多工作簿（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

但这只会插入新标签，并且不会使用现有标签结构。

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

Answer 1

由于22个工作簿只有1张，因此您无需遍历每张工作表。此外，您只需将工作表的包含复制到主菜单中所需的任何工作表上即可。

所以替换，

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

用

ThisWorkbook.Sheets("Extract 1").UsedRange.Value = ActiveWorkbook.Sheets(1).UsedRange.Value

注意：使用.UsedRange假设每个工作表中的数据结构与Extract表中的数据结构相同，并且没有合并的单元格。

假设您将第一个工作簿复制到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

将多个工作簿中的工作表复制到不同工作簿中的现有工作表中

1 个答案: