如何不使用Activate/Select将行复制到另一工作簿的工作表索引中

我是VBA新手，整合他人代码编写了如下程序，功能是将Sample2.xslx的Page1工作表中，包含Sample1.xslx各工作表名称（取自对应工作表A3单元格拆分后的第一个值）的行，复制到Sample1.xslx的对应工作表中。功能正常，但因大量使用Activate和Select函数导致运行极慢，希望在不使用这两个函数的前提下优化代码，同时保证功能正常。

原代码：

Sub Copy_Rows_Sample()

    Dim wb1 As Workbook, wb2 As Workbook
    Set wb1 = Workbooks.Open("C:\Sample1.xslx")
    Set wb2 = Workbooks.Open("C:\Sample2.xslx")
    
    Dim Page1 As Worksheet
    Set Page1 = wb2.Worksheets("Page1")
    
    wb1.Worksheets(1).Activate
    Excel.Application.DisplayAlerts = False
    Dim wksh As Excel.Worksheet
    Dim jIndex As Integer

    For jIndex = 1 To wb1.Worksheets.Count
    Set wksh = wb1.Worksheets(jIndex)
    With wksh
     
        Dim ran As Range
        For Each ran In Range("A3")
        ran = StrConv(ran.Text, vbProperCase)
        Next
        
        Z = Split(Range("A3").Value, ",")(0)
        ActiveSheet.name = Z
        Dim Y As Variant
        Set Y = ActiveSheet
    
        Page1.Activate
    
        Dim xRow&, NextRow&, LastRow&
        LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
        For xRow = 1 To LastRow
        NextRow = Y.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 2
        If WorksheetFunction.CountIf(Rows(xRow), "*" & Z & "*") > 0 Then
        Rows(xRow).Copy Y.Rows(NextRow)
        NextRow = NextRow + 1
        End If
    
        Next xRow
        
        Y.Activate
        wb1.Worksheets(ActiveSheet.Index Mod Worksheets.Count + 1).Select
        
    End With
    Next jIndex
    Excel.Application.DisplayAlerts = True

End Sub

优化后的代码 #

Sub Optimized_Copy_Rows()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim Page1 As Worksheet
    Dim wksh As Worksheet
    Dim jIndex As Integer
    Dim Z As String
    Dim lastRowPage1 As Long, nextRowDest As Long
    Dim xRow As Long
    Dim destLastRow As Long
    
    ' 关闭屏幕刷新、事件和警告，大幅提升运行速度
    With Excel.Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
    ' 直接引用工作簿和工作表对象，无需激活
    Set wb1 = Workbooks.Open("C:\Sample1.xslx")
    Set wb2 = Workbooks.Open("C:\Sample2.xslx")
    Set Page1 = wb2.Worksheets("Page1")
    
    ' 仅查找一次Page1的最后一行，避免重复操作
    lastRowPage1 = Page1.Cells.Find(What:="*", After:=Page1.Range("A1"), _
                                    SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    ' 遍历wb1的所有工作表
    For jIndex = 1 To wb1.Worksheets.Count
        Set wksh = wb1.Worksheets(jIndex)
        
        ' 简化A3单元格大小写转换，无需冗余循环
        wksh.Range("A3").Value = StrConv(wksh.Range("A3").Text, vbProperCase)
        
        ' 获取并修改工作表名称，直接操作对象
        Z = Split(wksh.Range("A3").Value, ",")(0)
        wksh.Name = Z
        
        ' 获取目标工作表初始复制位置，仅查找一次
        destLastRow = wksh.Cells.Find(What:="*", SearchOrder:=xlByRows, _
                                      SearchDirection:=xlPrevious).Row
        nextRowDest = destLastRow + 2
        
        ' 遍历Page1的行，复制匹配内容
        For xRow = 1 To lastRowPage1
            ' 明确指定Page1的行进行匹配检查
            If WorksheetFunction.CountIf(Page1.Rows(xRow), "*" & Z & "*") > 0 Then
                Page1.Rows(xRow).Copy Destination:=wksh.Rows(nextRowDest)
                nextRowDest = nextRowDest + 1
            End If
        Next xRow
    Next jIndex
    
    ' 恢复Excel默认设置
    With Excel.Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
    
    MsgBox "数据复制完成！", vbInformation
End Sub

关键优化说明 #

• 彻底移除Activate/Select：所有操作直接通过工作表对象（wksh、Page1）引用单元格和行，避免切换工作表带来的性能损耗
• 减少重复查找操作：lastRowPage1和destLastRow仅在必要时查找一次，避免每次循环调用Find函数浪费资源
• 明确对象归属：所有Range、Cells、Rows都指定所属工作表，避免隐式引用当前激活工作表导致的错误和性能问题
• 关闭冗余Excel功能：临时关闭屏幕刷新、事件触发，大幅降低运行时的系统开销
• 简化冗余代码：删除原代码中无意义的循环和工作表切换操作，精简逻辑

内容的提问来源于stack exchange，提问作者Anders J