Question

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

我正在使用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

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

2 个答案: