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