VBA：如何将两个工作簿之间的副本/粘贴扩展到两个工作簿中的所有工作簿

Question

我有许多Excel工作簿，其中包含25个以上工作表，每个工作表包含范围为1：500的20列数据（或部分为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 

我想，（直到我的指数为25或某事做出一个新的变量和运行一个for循环）作为替代，但同样我也许能解决这个问题作为一个for循环跨工作表的索引，我不知道如何将我的复制/粘贴从特定的表单指向另一个表单。我对这一点很陌生，只有Python/Java的半限制经验。这些VBA技能会在日常工作中大大受益。

两个文件中的问题： Ch00 Avoid

Ch00 Avoid1

Answer 1

谢谢大家的帮助。我昨天下午从头开始回到原来的地方，结束了下面的代码，至少在我看来，已经解决了我正在尝试做的事情。下一步将尝试使这个更乏味，因为我有一个gajillion工作簿来更新。如果我能找到一个不太讨厌的方式来打开/更新/保存/关闭新的工作簿，我将非常高兴。然而，现在，我必须打开示例工作簿和目标工作簿，同时保存并关闭...但它可以工作。

'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

Answer 2

这应该这样做。您应该可以将其放在空白工作簿中，以查看它是如何工作的（将几列数据放在列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