VBA - 如果满足条件，将模板工作表复制到另一个工作簿的多个工作表

Question

过去一周我一直在努力让代码正常工作，但没有成功。我尝试了各种修改，最终给出了不同的错误代码。

我遇到的第一个错误是 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

它是否可能被移动、重命名或删除？

我相信这行代码假设超链接应该打开另一个具有该名称的工作簿，但事实并非如此。摘要工作表上的超链接链接到同一主工作簿上的其他工作表，只有模板位于单独的工作簿上。

所以为了克服这个问题，我也尝试更改这一行并最终得到下面的代码，它设法打开模板工作簿，并将标签名称复制到第一张纸上，然后在下面的行中给出错误 @ 987654324@，说

下标超出范围

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

我尝试了更多变体，但无法复制正确的模板，切换回主工作簿工作表，通过链接在同一主工作簿中找到更正工作表，然后粘贴模板。

Answer 1

关于我对您的代码所做的修改的一些信息：

1. 不要使用整个 B 列，而是尝试仅使用 B 列中包含值的单元格。

2. 尽量避免使用ActiveWorkbook，如果代码位于同一个工作簿中，请改用ThisWorkbook。

3. 当您设置Range 时，通过声明Workbook 和Worksheet 来完全限定它，如：Set Rng = Sht.Range("B1:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row)。

4. 我将您的 2 个Ifs 替换为Select Case，因为它们的结果是相同的，并且它还可以让您在未来更灵活地添加更多案例。

5. 当您使用TemplateBook.Sheets("Red") 复制整个工作表并将其粘贴到另一个工作簿时，语法为TemplateBook.Sheets("Red").Copy after:=Sht。

代码

Option Explicit

Sub Summary()

    Dim MasterBook As Workbook
    Dim Sht As Worksheet
    Dim Rng As Range

    Set MasterBook = ThisWorkbook '<-- use ThisWorkbook not ActiveWorkbook
    Set Sht = MasterBook.Worksheets("Sheet3") '<-- define the sheet you want to loop thorugh (modify to your sheet's name)                
    Set Rng = Sht.Range("B1:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row) '<-- set range to all cells in column B with values

    Dim TemplateBook As Workbook
    Set TemplateBook = Workbooks.Open(Filename:="C:\Users\Desktop\Example template.xlsx")

    Dim cell As Range

    For Each cell In Rng
        Select Case cell.Value
            Case "Red", "Blue"
                cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True '<-- not so sure what values you have here
                TemplateBook.Sheets(cell.Value).Copy after:=Sht  '<-- paste after the sheet defined
            Case Else
                ' do something if you have other cases , not sure it's needed
        End Select
    Next cell

End Sub

---

编辑1：复制>>粘贴工作表的内容，使用下面的循环：

For Each cell In Rng
    Select Case cell.Value
        Case "Red", "Blue"
            cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True '<-- not so sure what values you have here
            Application.CutCopyMode = False
            TemplateBook.Sheets(cell.Value).UsedRange.Copy
            Sht.Range("A1").PasteSpecial     '<-- paste into the sheet at Range("A1")

        Case Else
            ' do something if you have other cases , not sure it's needed
    End Select
Next cell

---

编辑 2： 创建一个新工作表，然后将其重命名为 cell.Offset(0, -1).Value

TemplateBook.Sheets(cell.Value).Copy after:=Sht

Dim CopiedSheet As Worksheet
Set CopiedSheet = ActiveSheet
CopiedSheet.Name = cell.Offset(0, -1)