VBA - 如果條件符合，將模板表複製到另一個工作表的多個工作表中

Question

我一直在試圖讓代碼在過去的一週工作，沒有運氣。我嘗試了各種修改，最終給出了不同的錯誤代碼。

我得到的第一個錯誤是與Set rng = Intersect(.UsedRange, .Columns(2))

對象不支持

於是我改變了這個剛剛通過整列去該屬性或方法只是爲了看看它會工作：Set rng = Range("B:B")，當我這樣做然後它通讀，我得到一個錯誤Set HyperlinkedBook = Workbooks.Open(Filename:=cell.Offset(0, -1).Value)與錯誤代碼：

運行時錯誤1004對不起我們沒有找到24 James.xlsx

它可能被移動，重命名或刪除？

我相信這行代碼假設超鏈接應該打開具有該名稱的不同工作簿，但事實並非如此。彙總表上的超鏈接鏈接到同一主工作簿上的其他工作表，只有模板位於單獨的書上。

因此，爲了克服這個問題，我嘗試改變這一行，並最終以下面的代碼，它管理打開模板工作簿，並複製只是選項卡名稱到第一張表，然後給出以下行錯誤TemplateBook.Sheets("Red").Copy ActiveSheet.Paste，說

標出來

Sub Summary() 

    Dim MasterBook As Workbook 

    Set MasterBook = ActiveWorkbook 
    With MasterBook  
     Dim rng As Range 
     Set rng = Range("B:B")  
    End With 
    Dim TemplateBook As Workbook 
    Set TemplateBook = Workbooks.Open(Filename:=" C:\Users\Desktop\Example template.xlsx") 

    Dim cell As Range 
    For Each cell In rng 
     If cell.Value = "Red" Then 
      cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True 
      TemplateBook.Sheets("Red").Copy ActiveSheet.paste 
     ElseIf cell.Value = "Blue" Then 
cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True 
      TemplateBook.Sheets("Blue").Copy ActiveSheet.paste 
     End If  
    Next cell 

End Sub 

我試了更多的變化，但我不能得到它的拷貝正確的模板，切換回主簿片，FOL的範圍通過鏈接到相同主工作簿中的正確表單，然後粘貼模板。

Answer 1

約我對代碼進行修改幾點意見：

1. 而不是使用整列B的，儘量只使用在B列有在他們裏面值的單元格。

2. 儘量避免使用ActiveWorkbook，如果代碼位於同一工作簿中，則使用ThisWorkbook代替。

3. 當您設置一個Range，充分說明了Workbook和Worksheet，在限定它：Set Rng = Sht.Range("B1:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row)。

4. 我用Select Case取代了您的2 If s，因爲它們的結果是相同的，它還可以讓您在將來添加更多案例時具有更大的靈活性。

5. 當您使用TemplateBook.Sheets("Red")複製整個工作表並將其粘貼到另一個工作簿時，語法爲TemplateBook.Sheets("Red").Copy after:=Sht。

代碼

Option Explicit 

Sub Summary() 

    Dim MasterBook As Workbook 
    Dim Sht As Worksheet 
    Dim Rng As Range 

    Set MasterBook = ThisWorkbook '<-- use ThisWorkbook not ActiveWorkbook 
    Set Sht = MasterBook.Worksheets("Sheet3") '<-- define the sheet you want to loop thorugh (modify to your sheet's name)     
    Set Rng = Sht.Range("B1:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row) '<-- set range to all cells in column B with values 

    Dim TemplateBook As Workbook 
    Set TemplateBook = Workbooks.Open(Filename:="C:\Users\Desktop\Example template.xlsx") 

    Dim cell As Range 

    For Each cell In Rng 
     Select Case cell.Value 
      Case "Red", "Blue" 
       cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True '<-- not so sure what values you have here 
       TemplateBook.Sheets(cell.Value).Copy after:=Sht '<-- paste after the sheet defined 
      Case Else 
       ' do something if you have other cases , not sure it's needed 
     End Select 
    Next cell 

End Sub 

---

編輯1：複製>>片材的糊狀內容物，使用下面的循環：

For Each cell In Rng 
    Select Case cell.Value 
     Case "Red", "Blue" 
      cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True '<-- not so sure what values you have here 
      Application.CutCopyMode = False 
      TemplateBook.Sheets(cell.Value).UsedRange.Copy 
      Sht.Range("A1").PasteSpecial  '<-- paste into the sheet at Range("A1") 

     Case Else 
      ' do something if you have other cases , not sure it's needed 
    End Select 
Next cell 

---

編輯2：創建一個新的工作表，然後用cell.Offset(0, -1).Value

TemplateBook.Sheets(cell.Value).Copy after:=Sht 

Dim CopiedSheet As Worksheet 
Set CopiedSheet = ActiveSheet 
CopiedSheet.Name = cell.Offset(0, -1)