Vba 在单独工作簿上引用同一模板工作表的多个文本

我在下面有一个工作代码，但是我必须进一步开发它，以便能够识别引用同一模板的多个关键字

以下代码的功能是：

为a列中的每个单元格创建新工作表

新创建的工作表将是名为“模板工作簿”的第二个工作簿中模板的副本

共有5个模板工作表，复制的模板工作表取决于a列旁边B列中的文本条件

最初只有1个文本（在B列中）引用特定模板

由于B列中的文本与模板图纸名称相同，因此代码很简单

但是，现在我有多个文本引用同一个模板

所以我修改了代码，添加了额外的文本作为标准，并直接引用了模板，但它不再工作了

Option Explicit

Sub Summary()

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

    Set MasterBook = ThisWorkbook
    Set Sht = MasterBook.Worksheets("Sheet")
    Set Rng = Sht.Range("B6:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row)

    Dim TemplateBook As Workbook
    Set TemplateBook = Workbooks.Open(Filename:="T:\Contracts\Measure Templates.xlsx")

    Dim cell As Range

    For Each cell In Rng
        Select Case cell.Value
            Case "Standard Bathroom Template ", "Standard Kitchen Template ", "Standard Bathroom and Kitchen T ", "Windows only ", "Kitchen & Bathroom & Windows ", "Bathrooms & Windows ", "Kitchen & Windows "
                TemplateBook.Sheets(cell.Value).Copy after:=Sht

Dim CopiedSheet As Worksheet
Set CopiedSheet = ActiveSheet
CopiedSheet.Name = cell.Offset(0, -1)
        End Select
    Next cell
Call SaveAs
End Sub

Sub SaveAs()

    Dim FName           As String
    Dim FPath           As String

    FPath = "T:\Contracts\props"
    FName = Sheets("Sheet").Range("A2").Text
    ThisWorkbook.SaveAs Filename:=FPath & "\" & FName

End Sub

我将Case函数更改为：

Select Case cell.Value
        Case "Standard Bathroom Template ", "(B)", "(SOB)", "(S.O.B)"
        TemplateBook.Sheets("Standard Bathroom Template ").Copy after:=Sht

        Case "Standard Kitchen Template ", "(K)"
        TemplateBook.Sheets("Standard Kitchen Template ").Copy after:=Sht

        Case "Standard Bathroom and Kitchen T ", "(B,K)", "(K,B)"
        TemplateBook.Sheets("Standard Bathroom and Kitchen T ").Copy after:=Sht

        Case "Windows only ", "(W)", "(D)"
        TemplateBook.Sheets("Windows only ").Copy after:=Sht

        Case "Kitchen & Bathroom & Windows ", "(K,B,D)", "(K,B,D,W)", "(K,B,W,D)", "(B,K,D)", "(B,K,D,W)", "(B,K,W,D)"
        TemplateBook.Sheets("Kitchen & Bathroom & Windows").Copy after:=Sht

然而，对于新代码，它不再工作了。它创建第一张标有模板名称而不是单元格值的工作表，然后在出现错误“名称已被采用，请尝试其他名称”时停止。顺便说一句，a列上的列表中没有重复的名称

当列表中有重复项时，是否有方法发送消息

如何使新创建的选项卡与列中的列表顺序相同。现在它以相反的顺序创建它

最后，是否可以将新创建的工作表链接到汇总表中各自的单元格（A列）

---

复制模板时，您需要

设置复制页

，以便为以后提供参考

或使用ActiveSheet：

Sub Summary()
    Dim MasterBook As Workbook
    Dim Sht As Worksheet
    Dim Rng As Range

    Set MasterBook = ThisWorkbook
    Set Sht = MasterBook.Worksheets("Sheet")
    Set Rng = Sht.Range("B6:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row)

    Dim TemplateBook As Workbook
    Set TemplateBook = Workbooks.Open(Filename:="T:\Contracts\Measure Templates.xlsx")
    DoEvents

    Dim cell As Range
    Dim CopiedSheet As Worksheet
    Dim LastSheet As Worksheet

    For Each cell In Rng
        Set LastSheet = MasterBook.Sheets(MasterBook.Sheets.Count)
        Select Case cell.Value
            Case "Standard Bathroom Template ", "(B)", "(SOB)", "(S.O.B)"
                Call TemplateBook.Sheets("Standard Bathroom Template ").Copy(After:=LastSheet)
                Set CopiedSheet = ActiveSheet

            Case "Standard Kitchen Template ", "(K)"
                Call TemplateBook.Sheets("Standard Kitchen Template ").Copy(After:=LastSheet)
                Set CopiedSheet = ActiveSheet

            Case "Standard Bathroom and Kitchen T ", "(B,K)", "(K,B)"
                Call TemplateBook.Sheets("Standard Bathroom and Kitchen T ").Copy(After:=LastSheet)
                Set CopiedSheet = ActiveSheet

            Case "Windows only ", "(W)", "(D)"
                Call TemplateBook.Sheets("Windows only ").Copy(After:=LastSheet)
                Set CopiedSheet = ActiveSheet

            Case "Kitchen & Bathroom & Windows ", "(K,B,D)", "(K,B,D,W)", "(K,B,W,D)", "(B,K,D)", "(B,K,D,W)", "(B,K,W,D)"
                Call TemplateBook.Sheets("Kitchen & Bathroom & Windows").Copy(After:=LastSheet)
                Set CopiedSheet = ActiveSheet

            Case Else
                MsgBox "Case not handled!!!" & vbcrlf & cell.address & vbcrlf & cell.value, vbExclamation + vbOKOnly, "Error"
        End Select
        DoEvents
        CopiedSheet.Name = cell.Offset(0, -1)
        DoEvents
        If InStr(1, CopiedSheet.Name, " ") Then
            Sht.Hyperlinks.Add Anchor:=cell.Offset(0,-1), Address:="", SubAddress:="'" & CopiedSheet.Name & "'!A1", ScreenTip:=CStr(cell.Offset(0,-1).Value), TextToDisplay:=CStr(cell.Offset(0,-1).Value)
        Else
            Sht.Hyperlinks.Add Anchor:=cell.Offset(0,-1), Address:="", SubAddress:=CopiedSheet.Name & "!A1", ScreenTip:=CStr(cellcell.Offset(0,-1).Value), TextToDisplay:=CStr(cellcell.Offset(0,-1).Value)
        End If
        DoEvents
        Set CopiedSheet = Nothing
    Next cell

    'Call SaveAs
End Sub

---

感谢您的快速回复，但不幸的是，我在超链接行：Sht.Hyperlinks.Add cell“'”&CopiedSheet.Name&“！A1”中遇到了一个错误。错误消息是：参数不是可选的。我做了更改，不再出现错误，但是，现在模板无法打开，也不会创建新的工作表。它所做的唯一一件事是，将其保存在目标文件夹中，并将其重命名为单元格值（这是在第一个代码中调用的第二个代码“SaveAs”）@kira123:奇怪。。。尝试在select案例中放置断点，以确保代码流正在内部传递。因为没有理由任何事情都不会像这样发生……@R2uK我尝试了几种方法，但仍然没有成功。我删除了“call SaveAs”并删除了超链接行Sht.Hyperlinks.Add单元格“'”&CopiedSheet.Name&“！A1”。现在，它打开模板并创建一个新工作表，然后停止，出现错误：“需要对象”并突出显示“Set CopiedSheet=TemplateBook.Sheets…”创建的新工作表标记在模板名称之后，而不是单元格名称之后either@kira123太好了！！！！非常感谢您坚持到最后，非常感谢！！

Sub Summary()
    Dim MasterBook As Workbook
    Dim Sht As Worksheet
    Dim Rng As Range

    Set MasterBook = ThisWorkbook
    Set Sht = MasterBook.Worksheets("Sheet")
    Set Rng = Sht.Range("B6:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row)

    Dim TemplateBook As Workbook
    Set TemplateBook = Workbooks.Open(Filename:="T:\Contracts\Measure Templates.xlsx")
    DoEvents

    Dim cell As Range
    Dim CopiedSheet As Worksheet
    Dim LastSheet As Worksheet

    For Each cell In Rng
        Set LastSheet = MasterBook.Sheets(MasterBook.Sheets.Count)
        Select Case cell.Value
            Case "Standard Bathroom Template ", "(B)", "(SOB)", "(S.O.B)"
                Call TemplateBook.Sheets("Standard Bathroom Template ").Copy(After:=LastSheet)
                Set CopiedSheet = ActiveSheet

            Case "Standard Kitchen Template ", "(K)"
                Call TemplateBook.Sheets("Standard Kitchen Template ").Copy(After:=LastSheet)
                Set CopiedSheet = ActiveSheet

            Case "Standard Bathroom and Kitchen T ", "(B,K)", "(K,B)"
                Call TemplateBook.Sheets("Standard Bathroom and Kitchen T ").Copy(After:=LastSheet)
                Set CopiedSheet = ActiveSheet

            Case "Windows only ", "(W)", "(D)"
                Call TemplateBook.Sheets("Windows only ").Copy(After:=LastSheet)
                Set CopiedSheet = ActiveSheet

            Case "Kitchen & Bathroom & Windows ", "(K,B,D)", "(K,B,D,W)", "(K,B,W,D)", "(B,K,D)", "(B,K,D,W)", "(B,K,W,D)"
                Call TemplateBook.Sheets("Kitchen & Bathroom & Windows").Copy(After:=LastSheet)
                Set CopiedSheet = ActiveSheet

            Case Else
                MsgBox "Case not handled!!!" & vbcrlf & cell.address & vbcrlf & cell.value, vbExclamation + vbOKOnly, "Error"
        End Select
        DoEvents
        CopiedSheet.Name = cell.Offset(0, -1)
        DoEvents
        If InStr(1, CopiedSheet.Name, " ") Then
            Sht.Hyperlinks.Add Anchor:=cell.Offset(0,-1), Address:="", SubAddress:="'" & CopiedSheet.Name & "'!A1", ScreenTip:=CStr(cell.Offset(0,-1).Value), TextToDisplay:=CStr(cell.Offset(0,-1).Value)
        Else
            Sht.Hyperlinks.Add Anchor:=cell.Offset(0,-1), Address:="", SubAddress:=CopiedSheet.Name & "!A1", ScreenTip:=CStr(cellcell.Offset(0,-1).Value), TextToDisplay:=CStr(cellcell.Offset(0,-1).Value)
        End If
        DoEvents
        Set CopiedSheet = Nothing
    Next cell

    'Call SaveAs
End Sub