我在下面有一个工作代码，但我必须进一步开发它才能识别引用同一模板的多个关键字。
以下代码的功能是：
最初只有一个文本（在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
我将案例功能更改为：
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列）？
答案 0 :(得分：1)
复制模板时需要Set CopiedSheet以便稍后提供参考！ ;）
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)"
Set CopiedSheet = TemplateBook.Sheets("Standard Bathroom Template ").Copy(After:=LastSheet)
Case "Standard Kitchen Template ", "(K)"
Set CopiedSheet = TemplateBook.Sheets("Standard Kitchen Template ").Copy(After:=LastSheet)
Case "Standard Bathroom and Kitchen T ", "(B,K)", "(K,B)"
Set CopiedSheet = TemplateBook.Sheets("Standard Bathroom and Kitchen T ").Copy(After:=LastSheet)
Case "Windows only ", "(W)", "(D)"
Set CopiedSheet = TemplateBook.Sheets("Windows only ").Copy(After:=LastSheet)
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)"
Set CopiedSheet = TemplateBook.Sheets("Kitchen & Bathroom & Windows").Copy(After:=LastSheet)
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, Address:="", SubAddress:="'" & CopiedSheet.Name & "'!A1", ScreenTip:=CStr(cell.Value), TextToDisplay:=CStr(cell.Value)
Else
Sht.Hyperlinks.Add Anchor:=cell, Address:="", SubAddress:=CopiedSheet.Name & "!A1", ScreenTip:=CStr(cell.Value), TextToDisplay:=CStr(cell.Value)
End If
DoEvents
Set CopiedSheet = Nothing
Next cell
'Call SaveAs
End Sub
或使用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