如何按关键词将源表行复制插入主表对应位置？VBA代码优化求助

需求说明 #

需将源工作簿（SourceWb）的行复制插入到目标工作簿（DestWb主表）对应位置，匹配规则如下：

• 主表关键词DESIGN; PRODUCTION/ACTUAL ORDERS：对应源表E列值为Yes且D列不等于(DESIGN ONLY)的行
• DESIGN; DESIGN ONLY ORDERS：对应源表D列值为(DESIGN ONLY)的行
• OUTSOURCED：对应源表D列值为(OUTSOURCED)的行
• COMING UP…：对应源表E列值为No的行

当前代码问题 #

原代码运行后存在以下问题：

• 错误复制源表固定范围内容，包含大量空白行
• 未按关键词匹配规则将行插入到对应位置
• 存在语法错误导致逻辑异常

修正后的VBA代码 #

Sub PullTally()
    Dim pullFile As String
    Dim putFile As String
    Dim SourceWb As Workbook
    Dim DestWb As Workbook
    Dim destWS As Worksheet
    Dim sourceWS As Worksheet
    Dim sourceRowNum As Long
    Dim findTerm As String
    Dim findRange As Range
    Dim destInsertRow As Long
    
    ' 关闭屏幕刷新提升性能
    Application.ScreenUpdating = False
    
    ' 选择源文件与目标文件，处理用户取消情况
    pullFile = Application.GetOpenFilename(fileFilter:="Excel Files (*.xlsx;*.xls), *.xlsx;*.xls", Title:="选择源工作簿")
    If pullFile = "False" Then GoTo Cleanup
    putFile = Application.GetOpenFilename(fileFilter:="Excel Files (*.xlsx;*.xls), *.xlsx;*.xls", Title:="选择目标工作簿")
    If putFile = "False" Then GoTo Cleanup
    
    ' 打开工作簿并赋值工作表
    Set SourceWb = Workbooks.Open(Filename:=pullFile)
    Set DestWb = Workbooks.Open(Filename:=putFile)
    Set destWS = DestWb.Worksheets("Sheet1")
    Set sourceWS = SourceWb.Worksheets("Sheet1")
    
    ' 遍历源表所有有效数据行（假设表头在第1行）
    For sourceRowNum = 2 To sourceWS.Cells(sourceWS.Rows.Count, "D").End(xlUp).Row
        findTerm = ""
        With sourceWS
            ' 按规则匹配目标关键词，调整顺序避免逻辑覆盖
            Select Case True
                Case .Cells(sourceRowNum, "D").Value = "(DESIGN ONLY)"
                    findTerm = "DESIGN; DESIGN ONLY ORDERS"
                Case .Cells(sourceRowNum, "D").Value = "(OUTSOURCED)"
                    findTerm = "OUTSOURCED"
                Case .Cells(sourceRowNum, "E").Value = "No"
                    findTerm = "COMING UP…"
                Case .Cells(sourceRowNum, "E").Value = "Yes" And .Cells(sourceRowNum, "D").Value <> "(DESIGN ONLY)"
                    findTerm = "DESIGN; PRODUCTION/ACTUAL ORDERS"
                Case Else
                    ' 无匹配规则，跳过当前行
                    GoTo NextRow
            End Select
        End With
        
        ' 在目标表查找对应关键词
        With destWS
            Set findRange = .Columns(1).Find(What:=findTerm, LookIn:=xlValues, LookAt:=xlWhole)
            If Not findRange Is Nothing Then
                ' 确定插入位置：关键词行下方区块的最后一行+1
                If findRange.Offset(1).Value = "" Then
                    destInsertRow = findRange.Row + 1
                Else
                    destInsertRow = findRange.End(xlDown).Row + 1
                End If
                ' 复制插入行
                sourceWS.Rows(sourceRowNum).Copy
                .Rows(destInsertRow).Insert Shift:=xlDown
                Application.CutCopyMode = False ' 清除复制状态
            End If
        End With
        
NextRow:
    Next sourceRowNum
    
Cleanup:
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
    MsgBox "数据复制完成！", vbInformation
End Sub

关键修正说明 #

1. 修复语法错误：工作表对象赋值必须使用Set，原代码缺少Set导致运行报错
2. 遍历有效数据行：替换固定循环范围为动态获取源表最后一行，避免处理空白行
3. 修正匹配逻辑：调整Case顺序避免规则覆盖，补充第一个规则的D列不等于(DESIGN ONLY)条件，确保匹配准确
4. 优化文件选择：限制选择Excel文件，添加用户取消选择的处理逻辑
5. 提升运行效率：关闭屏幕刷新减少卡顿，完成后恢复
6. 完善插入逻辑：确保行插入到对应关键词区块的末尾，避免插入到错误位置

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