VBA - 根据摘要 Excel 表上的标准将工作簿中的不同模板表复制到另一个工作簿的多个工作表中答案

【问题标题】：VBA - copy different template sheets from a workbook, into multiple sheets of another workbook based on criteria on a summary excel sheetVBA - 根据摘要 Excel 表上的标准将工作簿中的不同模板表复制到另一个工作簿的多个工作表中
【发布时间】：2017-06-01 15:06:23
【问题描述】：

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

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

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

例如：

识别“主”工作簿中的单元格 B2 具有红色。
打开模板工作簿，
转到标记为红色的工作表
复制整张纸
返回“主”工作簿
单击 B2 旁边的单元格 (A2) 中的超链接名称
这会将您带到一张空白纸
粘贴模板
返回“主”工作簿并重复该列的其余部分
如果再次变成红色，则执行相同操作，如果是其他颜色（如蓝色），则复制粘贴蓝色模板表。

我自己尝试从其他论坛中提供的代码中编写代码，但它仅将粘贴复制到需要红色模板的 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

【问题讨论】：

要在此处获得有用的答案，请尝试实际编写代码并发布特定问题。没有人会为您编写完整的代码。您可以在这里或许多其他地方获得有关如何执行每个单独步骤的答案！
@Wolfie 感谢您的富有成效的评论，不幸的是，每个步骤的解释都不存在，因此发布了帖子。对于有答案的步骤，没有关于如何链接它们的解释，当我尝试将它们链接在一起时它不起作用。所以我最终得到的代码（使用我 3 天的编码经验）只是打开模板工作簿并粘贴在“主”工作簿的摘要表上。我很确定我拥有的代码将被大量更改甚至完全忽略，所以没有看到发布它的意义，但根据您的要求，我将为您编辑原始帖子。
复制工作表：stackoverflow.com/questions/7692274/… 打开工作簿stackoverflow.com/questions/26415179/… 那里有答案...我已经发布了一个基本代码来帮助您学习一些您需要的关键功能

标签： vba excel

【解决方案1】：

好的，这里有一些代码可以帮助您入门。我根据您提供的代码命名，这就是它有帮助的原因。我已经评论了很多以帮助您学习，实际上只有大约十几行代码！

注意：此代码可能无法“按原样”运行。尝试调整它，查看对象浏览器（在 VBA 编辑器中按 F2）和文档（将“MSDN”添加到 Google 搜索）以帮助您。

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

【讨论】：

非常感谢您的回复，这应该足以完成代码。我在摘要表中有超链接的原因是因为我有一个大约 40-50 个名称的列表，一旦将模板添加到每个相应的工作表中，每次交易时滚动工作表以查找相关工作表都会很痛苦与那个特定的人。那么是否可以保留超链接但使用 Set HyperlinkedBook = Workbooks.Open(Filename:=cell.Offset(0, -1).Value)。
很高兴我能提供帮助，请通过单击投票箭头下方的勾号将答案标记为已接受。谢谢。
也关于红色是字符串的一部分。例如，当我将蓝色和红色放在一起时，我有一个单独的模板，因此不希望粘贴仅红色模板或仅蓝色模板（这就是发生在我身上的事情）。那么“InStr”会是用来解决这个问题的东西吗？最后，模板文档位于网络驱动器中，但模板不会以任何方式被修改，只是从中复制，所以即使它处于只读状态也应该是可能的，不是吗？还是使用宏时会有所不同。
如果您有单独的模板，那么它只是您要匹配的不同字符串，例如“Red & Blue”，那么= 应该是正确的。在文档中查找 InStr 以满足您的需求。是的，复制工作表，ReadOnly 很好。你可以做set wbook = Workbooks.Open(filename:="filename", ReadOnly:=True)

【解决方案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

我尝试了更多变体，但我无法让它复制正确的模板，切换回主工作簿，通过摘要表上的链接找到正确的工作表（在同一个主工作簿中），并且粘贴模板。

【讨论】：