VBA：如何将两个工作簿之间的复制/粘贴扩展到两个工作簿的所有工作表

Question

我有大量的 Excel 工作簿，其中包含 25 个以上的工作表，每个工作表包含 20 列数据，范围为 1:500（或在某些情况下为 1:1000）。我经常负责更新“模板”，在该模板上输入新数据以进行新计算。我希望能够轻松地将旧工作表中的现有数据粘贴到具有新格式的工作表中，同时在新模板中保留任何新的格式/公式。

我正在使用 VBA 打开要复制的工作表并将其粘贴到新的模板工作表上。到目前为止，我的代码将从要复制的工作簿的第一张工作表 (S1) 中复制所有内容并将其粘贴到目标工作簿的第一张工作表 (S1) 上。

我想扩展此过程以遍历所有活动工作表（对工作簿中的每个工作表执行现在正在执行的操作）。我以前可以使用不同的代码来执行此操作，但它删除了我在粘贴时需要的第 503 行和第 506 行中的公式。我可以做一个 pastespecial 并跳过空单元格吗？我是新来的。

这是我当前的代码：

Sub CopyWS1()
Dim x As Workbook
Dim y As Workbook

Set x = Workbooks("Ch00 Avoid.xlsx")
Set y = Workbooks("Ch00 Avoid1.xlsx")
Dim LastRow As Long
Dim NextRow As Long

x.Worksheets("S1").Activate
Range("A65536").Select
ActiveCell.End(xlUp).Select
LastRow = ActiveCell.Row

Range("A2:T" & LastRow).Copy y.Worksheets("s1").Range("A1:A500")

Application.CutCopyMode = False

Range("A1").Select
End Sub

我相信我需要使用类似以下代码的代码才能将其扩展到工作表，但我不确定如何遍历工作表，因为我在上面的代码中专门引用了两个工作表。

     Sub WorksheetLoop2()

     ' Declare Current as a worksheet object variable.
     Dim Current As Worksheet

     ' Loop through all of the worksheets in the active workbook.
     For Each Current In Worksheets

        ' Insert your code here.
        ' This line displays the worksheet name in a message box.
        MsgBox Current.Name
     Next

     End Sub

我想我也许可以将这个问题作为一个跨工作表索引的 for 循环来解决（创建一个新变量并运行一个 for 循环，直到我的索引为 25 或其他东西）作为替代方案，但同样，我是不知道如何将我的复制/粘贴从特定工作表指向另一张工作表。我对此非常陌生，仅对 Python/Java 有半有限的经验。这些 VBA 技能将使我在日常生活中受益匪浅。

有问题的两个文件： Ch00 Avoid

Ch00 Avoid1

Answer 1

应该这样做。您应该能够将其放入空白工作簿中，以查看它是如何工作的（在几张纸上的 A 列中放置一些值）。显然，您将替换您的 wbCopy 和 wbPaste 变量，并从代码中删除 wbPaste.worksheets.add（我的 excel 仅在新工作簿中添加了 1 张工作表）。 LastRow 根据您的代码确定，从 A 列向上查找以找到最后一个单元格。 wsNameCode 用于确定您要查找的工作表的第一部分，因此您将其更改为“s”。

这将遍历复制工作簿中的所有工作表。对于这些工作表中的每一个，它将循环 1 到 20，以查看名称是否等于“s”+ 循环编号。您的 wbPaste 具有相同的工作表名称，因此当它在 wbCopy 上找到 s# 时，它将以相同的工作表名称粘贴到 wbPaste 中：s1 到 s1，s20 到 s20 等。我没有进行任何错误处理，因此，如果您的复制工作簿上有 s21，则粘贴工作簿上需要有 s21，并且 NumberToCopy 更改为 21（或者如果您打算添加更多，则将其设置为更高的数字）。

您可以让它只遍历前 20 张纸，但如果有人移动一张，它就会把它全部扔掉。这样，只要粘贴工作簿中存在工作表，工作簿中的工作表位置就无关紧要。

如果您不想癫痫发作，也可以关闭屏幕更新。

Option Explicit

Sub CopyAll()

'Define variables
Dim wbCopy As Workbook
Dim wsCopy As Worksheet
Dim wbPaste As Workbook
Dim LastRow As Long
Dim i As Integer
Dim wsNameCode As String
Dim NumberToCopy As Integer

'Set variables
i = 1
NumberToCopy = 20
wsNameCode = "Sheet"

'Set these to your workbooks
Set wbCopy = ThisWorkbook
Set wbPaste = Workbooks.Add
'These are just an example, delete when you run in your workbooks
wbPaste.Worksheets.Add
wbPaste.Worksheets.Add

'Loop through all worksheets in copy workbook
For Each wsCopy In wbCopy.Worksheets
    'Reset the last row to the worksheet, reset the sheet number search to 1
    LastRow = wsCopy.Cells(65536, 1).End(xlUp).Row
    i = 1
    'Test worksheet name to match template code (s + number)
    Do Until i > NumberToCopy
        If wsCopy.Name = (wsNameCode & i) Then
            wsCopy.Range("A2:T" & LastRow).Copy
            wbPaste.Sheets(wsNameCode & i).Paste
        End If
    i = i + 1
    Loop
Next wsCopy

End Sub

Answer 2

谢谢大家的帮助。昨天下午我从头开始返回并最终得到以下代码，至少在我看来，它已经解决了我想要做的事情。下一步将尝试使这不那么乏味，因为我有大量的工作簿要更新。如果我能找到一种不那么令人讨厌的方法来打开/更新/保存/关闭新工作簿，我会非常高兴。但是，就目前而言，我必须同时打开示例工作簿和目标工作簿，保存两者，然后关闭......但它可以工作。

'This VBA macro copies a range of cells from specified worksheets within one workbook to a range of cells
'on another workbook; the names of the sheets in both workbooks should be identical although can be edited to fit

Sub CopyToNewTemplate()

Dim x As Workbook
Dim y As Workbook
Dim ws As Worksheet
Dim tbc As Range
Dim targ As Range
Dim InxW As Long
Dim WshtNames As Variant
Dim WshtNameCrnt As Variant

'Specify the Workbook to copy from (x) and the workbook to copy to (y)
Set x = Workbooks("Ch00 Avoid.xlsx")
Set y = Workbooks("Ch00 Avoid1.xlsx")

'Can change the worksheet names according to what is in your workbook; both worksheets must be identical
WshtNames = Array("S1", "S2", "S3", "S4", "S5", "S6", "S7", "s8", "s9", "S10", "S11", "S12", "S13", "S14", "S15", _
                "S16", "S17", "S18", "S19", "S20", "Ext1", "Ext2", "Ext3", "EFS BigAverage")

'will iterate through each worksheet in the array, copying the tbc range and pasting to the targ range
For Each WshtNameCrnt In WshtNames
    With Worksheets(WshtNameCrnt)
        'tbc is tobecopied, specify the range of cells to copy; targ is the target workbook range
        Set tbc = x.Worksheets(WshtNameCrnt).Range("A1:T500")
        Set targ = y.Worksheets(WshtNameCrnt).Range("A1:T500")

        Dim LastRow As Long
        Dim NextRow As Long

        tbc.Copy targ
        Application.CutCopyMode = False
        
    End With
Next WshtNameCrnt


End Sub