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

我一直试图让代码在过去的一周工作，没有运气。 我尝试了各种修改，最终给出了不同的错误代码。

我得到的第一个错误是Set rng = Intersect(.UsedRange, .Columns(2))

对象不支持这个属性或方法

所以然后我改变这只是通过整个列只是为了看看它是否会工作： Set rng = Range("B:B") ，当我这样做然后它通读，我得到一个错误Set HyperlinkedBook = Workbooks.Open(Filename:=cell.Offset(0, -1).Value)与错误代码：

运行时错误1004对不起，我们无法find24个James.xlsx

它可能被移动，重命名或删除？

我相信这一行的代码是假设超链接应该打开一个不同的名称的工作簿，但事实并非如此。 汇总表上的超链接链接到同一主工作簿上的其他工作表，只有模板在单独的书上。

所以为了克服这个问题，我试着改变这一行，最后用下面的代码来pipe理打开模板工作簿，然后只复制标签名到第一张纸上，然后为下面的行提供一个错误TemplateBook.Sheets("Red").Copy ActiveSheet.Paste ，说

下标超出范围

 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. 我用Select Case取代了你的2个If ，因为它们的结果都是一样的，而且它还可以让你在未来增加更多的案例。

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：创build一个新的工作表，然后使用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)