VBA排序报错：第三次粘贴后无法排序，提示无效引用

执行以下VBA宏时，第三次粘贴操作后无法完成排序，在Next sourceRowNum前倒数第二行触发无效引用错误。需求是：以findRange作为排序范围的表头行，destInsertRow作为范围底部，将排序范围扩展至第14列，以findRange对应列作为关键字进行升序排序。

原错误代码 #

Sub PullTallyNEW()
 ' get source and destination workbook files
    Dim pullFile As String
    MsgBox ("Open Source Tally Workbook.")
    pullFile = Application.GetOpenFilename(fileFilter:="All Files (* . *) , * . * ")  'Copy From'
    Dim putFile As String
    MsgBox ("Open Destination Production List.")
    putFile = Application.GetOpenFilename(fileFilter:="All Files (* . *) , * . * ")   'Insert To'

    'open source workbook
    
    Dim SourceWb As Workbook
    Set SourceWb = Workbooks.Open(FileName:=pullFile)
    ' open destination workbook
    
    Application.ScreenUpdating = False
    
    Dim DestWb As Workbook
    Set DestWb = Workbooks.Open(FileName:=putFile)
    Dim destWS As Worksheet: Set destWS = DestWb.Worksheets("Sheet1")
    Dim sourceWS As Worksheet: Set sourceWS = SourceWb.Worksheets("Sheet1")
    Dim sourceRowNum As Long
    For sourceRowNum = 4 To 18 Step 1
        With sourceWS
            Dim findTerm As String
            Select Case True
                Case .Cells(sourceRowNum, 4).Value = "(OUTSOURCED)"
                    findTerm = "OUTSOURCED"
                Case .Cells(sourceRowNum, 4).Value = "(DESIGN ONLY)"
                    findTerm = "DESIGN; DESIGN ONLY ORDERS"
                Case .Cells(sourceRowNum, 5).Value = "No"
                    findTerm = "COMING UP…"
                Case .Cells(sourceRowNum, 5).Value = "Yes"
                    findTerm = "DESIGN; PRODUCTION/ACTUAL ORDERS"
                Case .Cells(sourceRowNum, 5).Value = "Approved"
                    findTerm = "COMING UP…"
                Case .Cells(sourceRowNum, 1).Value = ""
                    findTerm = "ON-HOLD"
                Case Else
            'can add other cases
            End Select
        End With
        With destWS
            Dim findRange As Range
            Set findRange = .Columns(1).Find(findTerm)
            If Not findRange Is Nothing Then
                Dim destInsertRow As Long
                If findRange.Offset(1).Value = "" Then
                    destInsertRow = findRange.Row + 1
                Else
                    destInsertRow = findRange.End(xlDown).Row + 1
                End If
            End If
                destWS.Rows(destInsertRow).Insert xlDown
                
                sourceWS.Cells(sourceRowNum, 11).Resize(1, 3).Copy
                destWS.Cells(destInsertRow, 1).PasteSpecial (xlPasteValues), SkipBlanks:=True
                
                sourceWS.Cells(1, 2).Copy
                destWS.Cells(destInsertRow, 5).PasteSpecial (xlPasteValues)
                                
                sourceWS.Cells(sourceRowNum, 6).Copy
                destWS.Cells(destInsertRow, 6).PasteSpecial (xlPasteValues), SkipBlanks:=True
                
                destWS.Rows(findRange.Row).Resize(findRange.Row, destInsertRow).Sort key1:=(findRange.Column), Order1:=xlAscending, Header:=xlYes
        End With
    Next sourceRowNum

    Application.ScreenUpdating = True

End Sub

错误原因分析 #

• 排序范围参数错误：原代码中Resize(findRange.Row, destInsertRow)参数顺序颠倒（Resize语法为Resize(行数, 列数)），且范围计算逻辑完全不符合需求，导致引用无效。
• 未处理空匹配情况：如果findTerm未找到，findRange会是Nothing，后续使用destInsertRow和findRange.Row会直接触发错误。
• 未扩展排序范围至第14列：原代码仅处理行范围，未明确指定列范围到第14列。
• 排序关键字格式错误：key1:=(findRange.Column)应传入Range对象，而非列号。

修复后的代码 #

Sub PullTallyNEW()
    ' 获取源文件和目标文件路径
    Dim pullFile As String
    MsgBox ("打开源统计工作簿。")
    pullFile = Application.GetOpenFilename(fileFilter:="所有文件 (*.*), *.*")  ' 复制来源
    Dim putFile As String
    MsgBox ("打开目标生产清单。")
    putFile = Application.GetOpenFilename(fileFilter:="所有文件 (*.*), *.*")   ' 插入目标

    ' 打开源工作簿
    Dim SourceWb As Workbook
    Set SourceWb = Workbooks.Open(FileName:=pullFile)
    ' 打开目标工作簿
    Application.ScreenUpdating = False
    
    Dim DestWb As Workbook
    Set DestWb = Workbooks.Open(FileName:=putFile)
    Dim destWS As Worksheet: Set destWS = DestWb.Worksheets("Sheet1")
    Dim sourceWS As Worksheet: Set sourceWS = SourceWb.Worksheets("Sheet1")
    Dim sourceRowNum As Long
    
    For sourceRowNum = 4 To 18 Step 1
        With sourceWS
            Dim findTerm As String
            Select Case True
                Case .Cells(sourceRowNum, 4).Value = "(OUTSOURCED)"
                    findTerm = "OUTSOURCED"
                Case .Cells(sourceRowNum, 4).Value = "(DESIGN ONLY)"
                    findTerm = "DESIGN; DESIGN ONLY ORDERS"
                Case .Cells(sourceRowNum, 5).Value = "No"
                    findTerm = "COMING UP…"
                Case .Cells(sourceRowNum, 5).Value = "Yes"
                    findTerm = "DESIGN; PRODUCTION/ACTUAL ORDERS"
                Case .Cells(sourceRowNum, 5).Value = "Approved"
                    findTerm = "COMING UP…"
                Case .Cells(sourceRowNum, 1).Value = ""
                    findTerm = "ON-HOLD"
                Case Else
                    ' 可添加其他匹配规则
            End Select
        End With
        
        With destWS
            Dim findRange As Range
            Set findRange = .Columns(1).Find(findTerm)
            
            ' 仅在找到匹配项时执行后续操作
            If Not findRange Is Nothing Then
                Dim destInsertRow As Long
                ' 确定插入行位置
                If findRange.Offset(1).Value = "" Then
                    destInsertRow = findRange.Row + 1
                Else
                    destInsertRow = findRange.End(xlDown).Row + 1
                End If
                
                ' 插入新行并复制数据
                .Rows(destInsertRow).Insert xlDown
                
                sourceWS.Cells(sourceRowNum, 11).Resize(1, 3).Copy
                .Cells(destInsertRow, 1).PasteSpecial xlPasteValues, SkipBlanks:=True
                
                sourceWS.Cells(1, 2).Copy
                .Cells(destInsertRow, 5).PasteSpecial xlPasteValues
                                
                sourceWS.Cells(sourceRowNum, 6).Copy
                .Cells(destInsertRow, 6).PasteSpecial xlPasteValues, SkipBlanks:=True
                
                ' 定义排序范围：从表头行到新插入行，扩展至第14列
                Dim sortRange As Range
                Set sortRange = .Range(findRange, .Cells(destInsertRow, 14))
                
                ' 执行排序：以表头所在列为关键字升序，指定表头行
                sortRange.Sort Key1:=.Cells(findRange.Row, findRange.Column), _
                               Order1:=xlAscending, _
                               Header:=xlYes
            End If
        End With
    Next sourceRowNum

    Application.ScreenUpdating = True
    MsgBox "操作完成！"
End Sub

关键修改点 #

• 增加空值判断：将所有依赖findRange的操作包裹在If Not findRange Is Nothing内，避免空引用错误。
• 修正排序范围：使用Range(findRange, .Cells(destInsertRow, 14))直接定义从表头到新行、第1列到第14列的范围，逻辑清晰准确。
• 修正排序关键字：传入Key1:=.Cells(findRange.Row, findRange.Column)明确指定表头单元格作为排序基准。
• 优化代码格式：移除冗余括号，统一代码风格，提升可读性。

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