VBA-根据摘要excel工作表上的条件，将不同的模板工作表从工作簿复制到另一工作簿的多个工作表中

我对VBA（3天经验）相当陌生，我已经浏览了几个论坛，但我找不到解决方案

我有两本作业本。“主”工作簿有一个摘要表，其中a列-名称列表超链接到同一工作簿中的空白表，每个选项卡的标签与该列中的名称相同。B列有1种颜色或颜色组合-有5种选择（红色、蓝色、绿色、蓝色和红色或红色和绿色）。 我有一个单独的模板工作簿，有5个模板页，每个模板页对应于颜色：标记为红色、蓝色、绿色、蓝色和红色或红色和绿色

我想要一个宏，该宏将通过我的“主”工作簿的B列，并根据颜色，从模板工作簿复制相应的模板，然后返回主工作簿。单击相邻a列中的链接，这将使其通过一个空工作表并粘贴模板。应重复此操作以遍历整个列

例如：

识别“主”工作簿中的单元格B2为红色

打开模板工作簿

转到标有红色的工作表

复制整张纸

返回“主”工作簿

单击B2旁边单元格（A2）中的超链接名称

这将把你带到一张空白的纸上

粘贴模板

返回“主”工作簿，重复本专栏的其余部分

如果它再次是红色，那么做同样的，如果一个不同的颜色像蓝色，那么复制粘贴蓝色模板表 我试着自己从其他论坛上可以得到的东西中编写代码，但它只将粘贴到“主”工作簿的前2页上，其中10页需要红色模板。到目前为止，我只为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

子摘要（）
变暗rng As范围
我想我会坚持多久
设置rng=范围（“B:B”）
对于rng中的每个单元
如果单元格值为“红色”，则单元格偏移量（0，-1）。选择
ActiveCell.Hyperlinks（1）.遵循NewWindow:=False，AddHistory:=True
工作簿。打开的文件名：=_
“T:\Contracts\color Templates.xlsx”
图纸（“红色模板”）。选择
单元格。选择
选择，复制
Windows（“Master.xlsx”）。激活
ActiveSheet.Range（“A1”）。选择
活动表。粘贴
下一个
端接头

好的，这里有一些代码让您开始学习。我根据您提供的代码命名，这就是为什么它很有用。为了帮助您学习，我已经对此进行了很多评论，实际上只有十几行代码

注意：此代码可能无法“按原样”工作。尝试并调整它，查看对象浏览器（在VBA编辑器中按F2）和文档（在谷歌搜索中添加“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

子摘要（）
“使用with语句意味着以“.”开头的任何代码短语都先假定with位
'所以ActiveSheet.Range（“…”）现在可以变成.Range（“…”）
作为工作簿的Dim MasterBook
设置MasterBook=ActiveWorkbook
将HyperlinkedBook设置为工作簿
随书
'将范围限制在UsedRange中的第2列（或“B”）
“在整个柱子上循环将是疯狂的长！
变暗rng As范围
设置rng=Intersect（.UsedRange、.Columns（2））
以
'打开模板手册
Dim TemplateBook作为工作簿
Set TemplateBook=Workbooks.Open（文件名：=“T:\Contracts\color Templates.xlsx”）
'调暗循环变量
暗淡单元格作为范围
对于rng中的每个单元
比较值在这里是有效的，但如果“红色”可能只是一个
'字符串的一部分，那么您可能需要查看InStr
如果cell.Value=“红色”，则
'尽量避免使用Select
'cell.Offset（0，-1）。超链接（1）。Follow NewWindow:=False，AddHistory:=True
“如果是Excel文档，最好不要使用超链接。相反
'如果单元格包含文件路径，请使用
设置HyperlinkedBook=Workbooks.Open（文件名：=cell.Offset（0，-1）.Value）
'如果这是在网络驱动器上，您可能需要检查其他用户是否打开了它。
'这将导致它是只读的，请使用myWorkbook.ReadOnly=True进行检查，然后。。。
“复制整张纸
TemplateBook.Sheets（“红色模板”）.Copy after:=HyperlinkedBook.Sheets（HyperlinkedBook.Sheets.Count）
'将UsedRange复制到空白表格中，而不是复制整张表格（复制表格更好，但此处用于学习）
'HyperlinkedBook.Sheets.Add after:=HyperlinkedBook.Sheets.Count
'TemplateBook.sheets（“红色模板”）.usedrange.copy目的地：=masterbook.sheets（“粘贴到此SheetName”）.Range（“A1”）
ElseIf cell.Value=“蓝色”则
' 
如果结束
下一个细胞
端接头

使用宏记录器帮助您学习如何执行简单任务：

然后尝试编辑代码，避免使用

Select

：

---

过去一周，我一直在努力让代码正常工作，但运气不佳。我尝试了各种修改，最终给出了不同的错误代码。我遇到的第一个错误是

Set rng=Intersect（.UsedRange，.Columns（2））

“对象不支持此属性或方法” 然后我把它改成只浏览整个专栏，看看它是否有效。

设置rng=范围（“B:B”）

。 当我这样做的时候，它就会通读，我得到一个错误，错误代码是：

Set HyperlinkedBook=Workbooks.Open（Filename:=cell.Offset（0，-1）.Value）

，错误代码是：运行时错误1004很抱歉，我们找不到24 James.xlsx。是否可能已将其移动、重命名或删除？” 我相信这行代码是假设超链接应该以该名称打开另一个工作簿，但事实并非如此。Sum上的超链接

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