多个文本引用到单独的工作簿上相同的模板工作表

我有一个工作代码下面，但是我不得不进一步发展，以便能够识别多个关键字引用相同的模板。

下面的代码的function是：

1. 为列A中的每个单元格创build一个新工作表
2. 新创build的工作表将成为第二个工作簿中名为“模板工作簿”的模板的副本
3. 有5个模板工作表，复制的模板工作表取决于B列旁边的文本条件

原来只有一个文本（在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 

我将案例function更改为：

 Select Case cell.Value Case "Standard Bathroom Template ", "(B)", "(SOB)", "(SOB)" 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 

1. 但是用新的代码，它不再工作。 它会创build第一个标有模板名称而不是单元格值的工作表，然后停止并出现错误“名称已被占用，请尝试其他名称”。A列btw没有名称重复列表。

2. 当列表中有重复时，有没有办法给出消息？

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

4. 最后是否可以将新创build​​的工作表超链接到汇总表中的各个单元格（A列）？

Answer 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)", "(SOB)" 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)", "(SOB)" 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