vba - 在不同的工作表中复制选项卡内容

Question

我从 SAP 中获取了一个通常有 40 个选项卡的提取。然后，我需要将其内容复制到另一个工作簿(我的模板)的其他选项卡中。该模板由 40 个输入选项卡组成。对于每个输入选项卡，始终有一个提取的选项卡，我将粘贴其中的内容。我一直在尝试使用以下代码自动执行此任务。

Option Explicit

Sub copytabs()
    Workbooks("test").Worksheets("sheet1").Range("A1:PPP999").Copy
    Workbooks("test2").Worksheets("sheet1").Activate
    Range("B2").Select
    ActiveSheet.Paste
    Workbooks("test").Worksheets("sheet3").Range("A1:PPP999").Copy
    Workbooks("test2").Worksheets("sheet3").Activate
    Range("B2").Select
    ActiveSheet.Paste
    Workbooks("test").Worksheets("sheet5").Range("A1:PPP999").Copy
    Workbooks("test2").Worksheets("sheet5").Activate
    Range("B2").Select
    ActiveSheet.Paste
End Sub

这段代码完成工作的速度非常慢。我尝试在 Array 上工作，但运气不佳。你们有什么建议吗？干杯法比

Answer 1

无需使用.Activate和.Select。它们会让你的代码变慢。您可能还想查看How to avoid using Select in Excel VBA macros

如果工作表名称类似于 Sheet1, Sheet2...Sheet40，您也可以在循环中编写上述代码

Option Explicit

Sub copytabs()
    Dim wbI As Workbook, wbO As Workbook
    Dim i As Long

    Set wbI = Workbooks("test")
    Set wbO = Workbooks("test2")

    Application.ScreenUpdating = False

    For i = 1 To 40 Step 2
        wbI.Sheets("sheet" & i).Range("A1:PPP999").Copy _
        wbO.Sheets("sheet" & i).Range("B2")

        DoEvents
    Next i

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

顺便说一句，创建工作簿 test 的副本并将其重命名为 Test2 会更快吗？

编辑

my extraction has 40 tabs and each of them has a name. For example Praline 1617, Total Company 1617 and so on...Then I paste their contents in tabs named exactly like their original. So my template has the same tabs name of the extraction. – Fabi 1 min ago

这是你想要的吗？

Option Explicit

Sub copytabs()
    Dim wbI As Workbook, wbO As Workbook
    Dim ws As Worksheet

    Set wbI = Workbooks("test")
    Set wbO = Workbooks("test2")

    Application.ScreenUpdating = False

    For Each ws In wbI.Worksheets
        ws.Range("A1:PPP999").Copy wbO.Sheets(ws.Name).Range("B2")

        DoEvents
    Next ws

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub