Question

我对VBA很新（演出3天），我已经浏览了几个论坛，但我找不到解决方案。

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

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

例如：

识别“master”工作簿中的Cell B2颜色为红色。
打开模板工作簿
转到标有红色的表格
复制整张表
返回“主”工作簿
点击B2
这将带您到一张白纸
粘贴模板
返回“Master”工作簿并重复本专栏的其余部分
如果它再次变红，那么就做同样的事，如果有不同颜色的蓝色，那么复制粘贴蓝色模板表。

我曾尝试使用其他论坛中提供的代码自行编写代码，但它只会将粘贴复制到10张需要红色模板的“Master”工作簿的前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）和文档（将“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

使用Macro Recorder帮助您学习如何完成简单的任务：

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。是否有可能被移动，重命名或删除？“ 我相信这行代码假设超链接应该打开一个具有该名称的不同工作簿，但事实并非如此。摘要表上的超链接链接到同一主工作簿上的其他工作表，只有模板位于单独的工作簿上。因此，为了克服这个问题，我尝试更改此行，最后使用下面的代码，该代码设法打开模板工作簿，并将选项卡名称复制到第一个工作表上，然后为以下行{{1}提供错误}，说“下标超出范围”

TemplateBook.Sheets("Red").Copy ActiveSheet.Paste

我尝试了多个变种，但我无法让它复制正确的模板，切换回主工作簿，按照摘要表上的链接到正确的工作表（在同一个主工作簿中），以及粘贴模板。

VBA - 根据摘要Excel工作表

2 个答案: