VBA工作表分类代码随机失效：Len函数返回值异常求助

需求说明 #

代码用于将"report_job"工作表的数据按以下规则分配至6个工作表：

• 若编号存在子编号（如A列的6002与6002A），将原编号与子编号行复制到Sheet1；
• 若不满足规则1，且Q列属于Category5或Category6，复制到Sheet6；
• 若前两条规则都不满足，根据C列的Status1-4分别复制到Sheet2至Sheet5。

数据示例 #

问题现象 #

代码随机失效，约50%概率下，NumLength1 = Len(Cells(FirstNumber, 1).Value)返回0（实际A列单元格内容长度至少为4），此时所有600多行数据会错误被分到Sheet1；正常运行时分类逻辑正确。

原代码 #

Sub Sorter()
Dim FirstNumber As Long
Dim SecondNumber As Variant
Dim LastRow As Long
Dim ColumnA As Range
Dim NumLength1 As Integer
Dim NumLength2 As Integer
Dim GetNumber1 As Long
Dim GetNumber2 As Long

   With Worksheets("report_job")
      LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With

i = 1
j = 1
k = 1
l = 1
m = 1
n = 1
Worksheets("Sheet1").Cells.Clear
Worksheets("Sheet2").Cells.Clear
Worksheets("Sheet3").Cells.Clear
Worksheets("Sheet4").Cells.Clear
Worksheets("Sheet5").Cells.Clear
Worksheets("Sheet6").Cells.Clear

    With Sheets("report_job")
        For FirstNumber = 2 To LastRow
        
            NumLength1 = Len(Cells(FirstNumber, 1).Value)
            
            For g = 1 To NumLength1
                If (IsNumeric(Mid(Cells(FirstNumber, 1).Value, g, 1))) Then result = result & Mid(Cells(FirstNumber, 1).Value, g, 1)
            Next g
            
            GetNumber1 = result
            result = Empty
            
            For h = 1 To NumLength1
                If (IsNumeric(Mid(Cells(FirstNumber + 1, 1).Value, h, 1))) Then result = result & Mid(Cells(FirstNumber + 1, 1).Value, h, 1)
            Next h
            
            GetNumber2 = result
            result = Empty
            
                If GetNumber1 = GetNumber2 Or Len(Cells(FirstNumber, 1).Value) > Len(GetNumber1) Then
                        .Rows(FirstNumber).Copy Destination:=Worksheets("Sheet1").Range("A" & i)
                        i = i + 1
                    GetNumber1 = Empty
                    GetNumber2 = Empty
                Else
                    If .Cells(FirstNumber, 3).Value = "Status1" And .Cells(FirstNumber, 17).Value <> "Category5" And .Cells(FirstNumber, 17).Value <> "Category6" Then
                        .Rows(FirstNumber).Copy Destination:=Worksheets("Sheet2").Range("A" & j)
                        j = j + 1
                    ElseIf .Cells(FirstNumber, 3).Value = "Staus2" And .Cells(FirstNumber, 17).Value <> "Category5" And .Cells(FirstNumber, 17).Value <> "Category6" Then
                        .Rows(FirstNumber).Copy Destination:=Worksheets("Sheet3").Range("A" & k)
                        k = k + 1
                    ElseIf .Cells(FirstNumber, 3).Value = "Status3" And .Cells(FirstNumber, 17).Value <> "Category5" And .Cells(FirstNumber, 17).Value <> "Category6" Then
                        .Rows(FirstNumber).Copy Destination:=Worksheets("Sheet4").Range("A" & l)
                        l = l + 1
                    ElseIf .Cells(FirstNumber, 3).Value = "Status4" And .Cells(FirstNumber, 17).Value <> "Category5" And .Cells(FirstNumber, 17).Value <> "Category6" Then
                        .Rows(FirstNumber).Copy Destination:=Worksheets("Sheet5").Range("A" & m)
                        m = m + 1
                    ElseIf .Cells(FirstNumber, 17).Value = "Category5" Or .Cells(FirstNumber, 17).Value = "Category6" Then
                        .Rows(FirstNumber).Copy Destination:=Worksheets("Sheet6").Range("A" & n)
                        n = n + 1
                    End If
                End If
            GetNumber1 = Empty
            GetNumber2 = Empty
        Next FirstNumber
    End With

End Sub

问题分析 #

1. 工作表引用未限定：在With Sheets("report_job")代码块中，Cells(FirstNumber, 1).Value未添加.前缀，导致代码会读取当前激活工作表的单元格，而非固定的"report_job"。如果运行时其他工作表处于激活状态，就会读取空单元格，导致Len返回0，触发错误分类逻辑。这是随机失效的核心原因。
2. 变量未声明：result变量未提前声明，属于隐式变体类型，容易残留上一次循环的意外值，导致编号提取错误。
3. 循环越界：当FirstNumber等于LastRow时，FirstNumber + 1会超出数据范围，读取空单元格，导致GetNumber2出错。
4. 拼写错误：代码中Staus2是拼写错误，应为Status2，会导致Status2的数据无法正确分配到Sheet3。
5. 编号提取逻辑冗余：逐字符提取数字的方式效率低，且容易出错。

修复方案 #

1. 所有单元格引用前添加.前缀，确保在With块中始终指向"report_job"工作表；
2. 声明所有变量，包括result，避免隐式类型错误；
3. 处理最后一行的边界情况，避免读取超出范围的单元格；
4. 修正Staus2的拼写错误；
5. 优化编号提取逻辑，使用更简洁的方式提取数字部分；
6. 关闭屏幕刷新、禁用事件提升运行效率；
7. 简化复制逻辑，减少重复代码。

修正后代码 #

Sub Sorter_Fixed()
    Dim FirstNumber As Long
    Dim LastRow As Long
    Dim GetNumber1 As Long
    Dim GetNumber2 As Long
    Dim result As String ' 显式声明变量
    Dim wsSource As Worksheet
    Dim wsDest(1 To 6) As Worksheet
    Dim destRow(1 To 6) As Long
    
    ' 初始化工作表对象
    Set wsSource = ThisWorkbook.Worksheets("report_job")
    Set wsDest(1) = ThisWorkbook.Worksheets("Sheet1")
    Set wsDest(2) = ThisWorkbook.Worksheets("Sheet2")
    Set wsDest(3) = ThisWorkbook.Worksheets("Sheet3")
    Set wsDest(4) = ThisWorkbook.Worksheets("Sheet4")
    Set wsDest(5) = ThisWorkbook.Worksheets("Sheet5")
    Set wsDest(6) = ThisWorkbook.Worksheets("Sheet6")
    
    ' 初始化目标行号
    For i = 1 To 6
        wsDest(i).Cells.Clear
        destRow(i) = 1
    Next i
    
    ' 获取数据源最后一行
    LastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' 关闭屏幕刷新提升效率
    Application.ScreenUpdating = False
    
    With wsSource
        For FirstNumber = 2 To LastRow
            ' 提取当前行编号的数字部分
            result = ""
            For g = 1 To Len(.Cells(FirstNumber, 1).Value)
                If IsNumeric(Mid(.Cells(FirstNumber, 1).Value, g, 1)) Then
                    result = result & Mid(.Cells(FirstNumber, 1).Value, g, 1)
                End If
            Next g
            GetNumber1 = CLng(result)
            
            ' 处理最后一行，避免越界
            GetNumber2 = -1
            If FirstNumber < LastRow Then
                result = ""
                For g = 1 To Len(.Cells(FirstNumber + 1, 1).Value)
                    If IsNumeric(Mid(.Cells(FirstNumber + 1, 1).Value, g, 1)) Then
                        result = result & Mid(.Cells(FirstNumber + 1, 1).Value, g, 1)
                    End If
                Next g
                If result <> "" Then GetNumber2 = CLng(result)
            End If
            
            ' 判断规则1：存在子编号
            If (FirstNumber < LastRow And GetNumber1 = GetNumber2) Or Len(.Cells(FirstNumber, 1).Value) > Len(CStr(GetNumber1)) Then
                .Rows(FirstNumber).Copy Destination:=wsDest(1).Range("A" & destRow(1))
                destRow(1) = destRow(1) + 1
            Else
                ' 判断规则2：Category5/6
                If .Cells(FirstNumber, 17).Value = "Category5" Or .Cells(FirstNumber, 17).Value = "Category6" Then
                    .Rows(FirstNumber).Copy Destination:=wsDest(6).Range("A" & destRow(6))
                    destRow(6) = destRow(6) + 1
                Else
                    ' 判断规则3：按Status分配
                    Select Case .Cells(FirstNumber, 3).Value
                        Case "Status1"
                            .Rows(FirstNumber).Copy Destination:=wsDest(2).Range("A" & destRow(2))
                            destRow(2) = destRow(2) + 1
                        Case "Status2" ' 修正拼写错误
                            .Rows(FirstNumber).Copy Destination:=wsDest(3).Range("A" & destRow(3))
                            destRow(3) = destRow(3) + 1
                        Case "Status3"
                            .Rows(FirstNumber).Copy Destination:=wsDest(4).Range("A" & destRow(4))
                            destRow(4) = destRow(4) + 1
                        Case "Status4"
                            .Rows(FirstNumber).Copy Destination:=wsDest(5).Range("A" & destRow(5))
                            destRow(5) = destRow(5) + 1
                    End Select
                End If
            End If
        Next FirstNumber
    End With
    
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
    
    ' 释放对象
    Set wsSource = Nothing
    For i = 1 To 6
        Set wsDest(i) = Nothing
    Next i
End Sub

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