VBA：如何将两个工作簿之间的复制/粘贴扩展到这两个工作簿的所有工作表
我有大量的Excel工作簿，其中包含25个以上的工作表，每个工作表包含范围为1：500（或某些情况下为1：1000）的20列数据。 我经常负责更新input新数据的“模板”以进行新的计算。 我希望能够将旧工作表中的现有数据轻松地粘贴到具有新格式的工作表中，同时保留新模板中的任何新格式/公式。
我正在使用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循环索引的工作表（做一个新的variables，并运行一个for循环，直到我的索引是25或什么）作为替代，但我不知道如何指向从特定工作表复制/粘贴到另一个工作表。 我对这个只有Python / Java的半限制的经验非常新。 这些VBA技能会使我日益受益。
有问题的两个文件： Ch00避免
Ch00避免1
这应该做到这一点。 你应该能够把它放在一个空白的工作簿中，看看它是如何工作的（把一些值放在A列中的几张）。 显然，你会replace你的wbCopy和wbPastevariables，并从代码中删除wbPaste.worksheets.add（我的Excel只在新的工作簿中添加1张）。 LastRow是根据您的代码确定的，从列A查找以查找最后一个单元格。 wsNameCode用于确定您正在查找的工作表的第一部分，因此您将其更改为“s”。
这将循环遍历复制工作簿中的所有工作表。 对于每个表单，它将循环1到20来查看名称是否等于“s”+循环数。 您的wbPaste具有相同的表名，所以当它在wbCopy上finds＃时，它将粘贴到具有相同表名的wbPaste中：s1到s1，s20到s20等。我没有进行任何error handling，所以如果你的复制工作簿上有s21，s21需要放在你的粘贴工作簿上，而NumberToCopy改为21（或者如果你打算增加更多的话，就把它设置成更高的数字）。
你可能只是循环前20张，但如果有人移动一个，它会把它扔掉。 只要它存在于粘贴工作簿中，这种工作表中的表单放置就不相关。
如果您不想扣押，也可以closures屏幕更新。
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
感谢你的帮助，每个人。 我昨天下午从零开始回到原来的地方，结束了下面的代码，至less在我看来，已经解决了我正在尝试做的事情。 下一步将是尽量减less繁琐，因为我有一个gajillion工作簿来更新。 如果我能find一个不太讨厌的方式来打开/更新/保存/closures新的工作簿，我将会非常高兴。 但现在，我必须同时打开示例工作簿和目标工作簿，同时保存并closures…但它工作正常。
'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