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 

我试了更多的变化，但我不能得到它通过正确的汇总表的链接复制正确的模板，切换回主簿，请按照工作表（在同一个主工作簿中），然后粘贴模板。