Question

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

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

Object不支持此属性或方法

然后我将此更改为仅浏览整个列，只是为了查看它是否可行：Set rng = Range("B:B")，当我这样做时，它会读取并且我得到Set HyperlinkedBook = Workbooks.Open(Filename:=cell.Offset(0, -1).Value)的错误错误代码：

运行时错误1004抱歉，我们找不到24 James.xlsx

是否可以移动，重命名或删除？

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

所以为了解决这个问题，我尝试更改此行，最后使用下面的代码，该代码设法打开模板工作簿，并将选项卡名称复制到第一个工作表上，然后给出以下行的错误{ {1}}，说

下标超出范围

TemplateBook.Sheets("Red").Copy ActiveSheet.Paste

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

Answer 1

关于我对您的代码所做的修改的一些评论：

尝试仅使用B列中包含值的单元格，而不是使用整个B列。
尽量避免使用ActiveWorkbook，如果代码位于同一工作簿中，则使用ThisWorkbook代替。
当您设置Range时，请通过声明Workbook和Worksheet完全限定它，如：Set Rng = Sht.Range("B1:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row)。
我用If替换了您的2 Select Case，因为它们两者的结果是相同的，并且它还可以让您在将来更灵活地添加更多案例。< / p>
使用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：复制＆gt;＆gt;粘贴工作表内容，使用以下循环：

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)

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

1 个答案: