VBA - 從工作簿中複製不同的模板，根據總結excel表中的條件複製到另一個工作簿的多個工作表

Question

我對VBA非常新（3天的exp），我已經瀏覽了幾個論壇，但是我找不到解決方案。

我有2個工作簿。 「主」工作簿包含一個彙總表，其中有A列 - 名稱列表超鏈接到同一工作簿中的空白工作表，標籤與列中的名稱相同。 B列有1個或其組合顏色 - 有5個選項（紅色，藍色，綠色，藍色&紅色或紅色&綠色）。 我有一個單獨的模板工作簿，其中有5個模板工作表，每個模板工作表對應於顏色：標有紅色，藍色，綠色，藍色&紅色或紅色&綠色。

我想要一個宏將通過我的「主」工作簿的B列，並根據顏色，從模板工作簿中複製相應的模板，然後返回到主工作簿單擊通過相鄰的鏈接列A，它將把它帶到一個空白表格並粘貼模板。這應該重複遍歷整個列。

例如：

1. 認識到，在 「主」 細胞簿B2具有紅色。
2. 打開該模板的工作簿，
3. 去標記紅色
4. 複製整個工作表
5. 回到「主」工作簿
6. 單擊超鏈接名稱在單元格（A2）的片旁邊B2
7. 這將帶你到一個空白頁
8. 粘貼模板
9. 回到「大師」的工作簿，並重複列的其餘
10. 如果再紅一下，那麼照做不變，如果不同的顏色像藍色一樣，那就複製粘貼藍色模板表。

我試圖從其他論壇中可用的代碼中自行編寫代碼，但它僅將粘貼複製到需要紅色模板的10張工作表的「主」工作簿的前2張上。我因爲如果加1倍標準沒有意義只寫它的1倍顏色的標準至今沒有工作：

Sub Summary()  
Dim rng As Range  
Dim i As Long  
Set rng = Range("B:B") 
For Each cell In rng  
If cell.Value <> "Red" Then cell.Offset(0, -1).select 
ActiveCell.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True 
Workbooks.Open Filename:= _ 
    "T:\Contracts\Colour Templates.xlsx" 


Sheets("Red Template").Select 
Cells.Select 
Selection.Copy 
Windows("Master.xlsx").Activate 
ActiveSheet.Range(「A1」).select 

ActiveSheet.Paste 
Next 
End Sub 

Answer 1

好了，所以這裏的一些代碼，讓你開始。我根據您提供的代碼創建了名稱，這就是爲什麼它很有用。我已經評論了很多，試圖幫助你的學習，實際上只有十幾行代碼！

注意：此代碼可能不會「按原樣」工作。嘗試並調整它，查看對象瀏覽器（在VBA編輯器中按F2）和文檔（向Google搜索添加「MSDN」）以幫助您。

Sub Summary() 

    ' Using the with statement means any code phrase started with "." assumes the With bit first 
    ' So ActiveSheet.Range("...") can now become .Range("...") 

    Dim MasterBook As Workbook 
    Set MasterBook = ActiveWorkbook 

    Dim HyperlinkedBook As Workbook 

    With MasterBook 

     ' Limit the range to column 2 (or "B") in UsedRange 
     ' Looping over the entire column will be crazy long! 

     Dim rng As Range 
     Set rng = Intersect(.UsedRange, .Columns(2)) 

    End With 

    ' Open the template book 
    Dim TemplateBook As Workbook 
    Set TemplateBook = Workbooks.Open(Filename:="T:\Contracts\Colour Templates.xlsx") 

    ' Dim your loop variable 
    Dim cell As Range 
    For Each cell In rng 

     ' Comparing values works here, but if "Red" might just be a 
     ' part of the string, then you may want to look into InStr 
     If cell.Value = "Red" Then 
      ' Try to avoid using Select 
      'cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True 

      ' You are better off not using hyperlinks if it is an Excel Document. Instead 
      ' if the cell contains the file path, use 

      Set HyperlinkedBook = Workbooks.Open(Filename:=cell.Offset(0, -1).Value) 

      ' If this is on a network drive, you may have to check if another user has it open. 
      ' This would cause it to be ReadOnly, checked using If myWorkbook.ReadOnly = True Then ... 

      ' Copy entire sheet 
      TemplateBook.Sheets("Red Template").Copy after:=HyperlinkedBook.Sheets(HyperlinkedBook.Sheets.Count) 

      ' Instead of copying whole sheet, copy UsedRange into blank sheet (copy sheet is better but here for learning) 
      ' HyperlinkedBook.Sheets.Add after:=HyperlinkedBook.Sheets.Count 
      ' TemplateBook.sheets("Red Template").usedrange.copy destination:=masterbook.sheets("PasteIntoThisSheetName").Range("A1") 

     ElseIf cell.Value = "Blue" Then 

      ' <similar stuff here> 

     End If 

    Next cell 

End Sub 

使用宏錄製，以幫助你學習如何做簡單的任務：

http://www.excel-easy.com/vba/examples/macro-recorder.html

嘗試，然後編輯代碼，並避免使用Select：

How to avoid using Select in Excel VBA macros

Answer 2

我一直在努力讓代碼在過去的一週裏沒有運氣。我嘗試了各種修改，最終給出了不同的錯誤代碼。我得到的第一個錯誤是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 

我試了更多的變化，但我不能得到它通過正確的彙總表的鏈接複製正確的模板，切換回主簿，請按照工作表（在同一個主工作簿中），然後粘貼模板。