VBA跨表复制记录时If/StrComp逻辑触发Runtime error 1004报错

需求说明 #

从索引为j的其他工作表中复制最近3条操作记录（write ups）。所有目标工作表均包含表头，若工作表内无有效记录，程序会误抓取表头内容，后续2次循环将触发错误。需要实现逻辑：当程序尝试将表头作为有效记录抓取时，在活动工作表对应单元格填入"No Writeups"并终止当前循环，避免程序报错。

已尝试方案 #

A列第1行的表头文本为Date，遍历A列时尝试通过StrComp函数匹配"Date"文本（规避数值与字符串直接比较的异常），但程序运行时触发1004运行时错误。

原有问题代码 #

Dim FirstLine As String
Dim NewestEntry As Integer

   FirstLine = 6

Dim GrabbedDate As String

For j = 0 To 20 '(20) Tail Tabs/Number of Tabs

        NewestEntry = Worksheets(Tail(j)).Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count

    For k = NewestEntry To NewestEntry - 2 Step -1
                
            GrabbedDate = Worksheets(Tail(j)).Cells(k, 1).Text
            
            If StrComp(GrabbedDate, "Date") = 0 Then
                    k = 0
            
                If Not k = 1 Then
                
                    Worksheets(Tail(j)).Cells(k, 1).Copy Worksheets("StepBrief").Cells(FirstLine, 4)  'Date
                    Worksheets(Tail(j)).Cells(k, 4).Copy Worksheets("StepBrief").Cells(FirstLine, 5)  'Code
                    Worksheets(Tail(j)).Cells(k, 5).Copy Worksheets("StepBrief").Cells(FirstLine, 6)  'Pilot
                    Worksheets(Tail(j)).Cells(k, 8).Copy Worksheets("StepBrief").Cells(FirstLine, 7)  'Start Up
                    Worksheets(Tail(j)).Cells(k, 11).Copy Worksheets("StepBrief").Cells(FirstLine, 8) 'Airboorne
                    Worksheets(Tail(j)).Cells(k, 14).Copy Worksheets("StepBrief").Cells(FirstLine, 9) 'Shutdown
                    
                    FirstLine = FirstLine + 1
                    
                Else
                 If k = 1 Then
                    Worksheets("StepBrief").Cells(FirstLine, 4).Value = ""                  'Date
                    Worksheets("StepBrief").Cells(FirstLine, 5).Value = ""                  'Code
                    Worksheets("StepBrief").Cells(FirstLine, 6).Value = ""                  'Pilot
                    Worksheets("StepBrief").Cells(FirstLine, 7).Value = "No Write Up"       'Start Up
                    Worksheets("StepBrief").Cells(FirstLine, 8).Value = "No Write Up"       'Airboorne
                    Worksheets("StepBrief").Cells(FirstLine, 9).Value = "No Write Up"       'Shutdown
                    
                    FirstLine = FirstLine + 1
                
                End If
                End If
            End If

        Next k
    Next j

问题根因 #

• 分支逻辑顺序错乱：检测到单元格内容为"Date"时先将循环变量k赋值为0，后续分支判断基于k=0执行，会尝试访问行号为0的不存在单元格，直接触发1004运行时错误
• 循环终止方式错误：通过手动修改循环变量值的方式无法立即终止当前遍历流程，还会导致后续分支判断完全偏离预期
• 边界校验缺失：未提前判断工作表有效记录数量，当有效记录不足3条（仅含表头、仅1/2条有效记录）时，循环变量k会递减到1、0甚至负数，触发单元格越界访问
• 方法调用无容错：整列调用SpecialCells(xlCellTypeConstants)时，如果目标列不存在常量类型单元格，方法会直接抛出错误，无捕获处理机制
• 变量类型声明错误：存储行号的变量FirstLine被声明为String类型，存在类型不匹配隐患

修正后可运行代码 #

Dim FirstLine As Long
Dim NewestEntry As Long
Dim GrabbedDate As String
Dim j As Long, k As Long
Dim copiedCount As Long

FirstLine = 6

For j = 0 To 20 '遍历20个尾部工作表
    copiedCount = 0
    '容错处理：捕获SpecialCells无匹配内容的报错
    On Error Resume Next
    NewestEntry = Worksheets(Tail(j)).Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
    On Error GoTo 0
    
    '常量行总数≤1说明仅存在表头，无有效记录
    If NewestEntry <= 1 Then
        Worksheets("StepBrief").Cells(FirstLine, 4).Value = ""
        Worksheets("StepBrief").Cells(FirstLine, 5).Value = ""
        Worksheets("StepBrief").Cells(FirstLine, 6).Value = ""
        Worksheets("StepBrief").Cells(FirstLine, 7).Value = "No Write Up"
        Worksheets("StepBrief").Cells(FirstLine, 8).Value = "No Write Up"
        Worksheets("StepBrief").Cells(FirstLine, 9).Value = "No Write Up"
        FirstLine = FirstLine + 1
        GoTo NextSheet '直接跳转处理下一个工作表
    End If

    '从最新行开始倒序取数，最多取3条
    For k = NewestEntry To NewestEntry - 2 Step -1
        '行号小于1时直接终止，避免越界访问
        If k < 1 Then Exit For
        
        GrabbedDate = Worksheets(Tail(j)).Cells(k, 1).Text
        '匹配到表头内容时，填充提示后终止当前表取数
        If StrComp(GrabbedDate, "Date", vbTextCompare) = 0 Then
            Worksheets("StepBrief").Cells(FirstLine, 4).Value = ""
            Worksheets("StepBrief").Cells(FirstLine, 5).Value = ""
            Worksheets("StepBrief").Cells(FirstLine, 6).Value = ""
            Worksheets("StepBrief").Cells(FirstLine, 7).Value = "No Write Up"
            Worksheets("StepBrief").Cells(FirstLine, 8).Value = "No Write Up"
            Worksheets("StepBrief").Cells(FirstLine, 9).Value = "No Write Up"
            FirstLine = FirstLine + 1
            Exit For
        End If

        '复制有效记录
        Worksheets(Tail(j)).Cells(k, 1).Copy Worksheets("StepBrief").Cells(FirstLine, 4)  'Date
        Worksheets(Tail(j)).Cells(k, 4).Copy Worksheets("StepBrief").Cells(FirstLine, 5)  'Code
        Worksheets(Tail(j)).Cells(k, 5).Copy Worksheets("StepBrief").Cells(FirstLine, 6)  'Pilot
        Worksheets(Tail(j)).Cells(k, 8).Copy Worksheets("StepBrief").Cells(FirstLine, 7)  'Start Up
        Worksheets(Tail(j)).Cells(k, 11).Copy Worksheets("StepBrief").Cells(FirstLine, 8) 'Airborne
        Worksheets(Tail(j)).Cells(k, 14).Copy Worksheets("StepBrief").Cells(FirstLine, 9) 'Shutdown
        
        FirstLine = FirstLine + 1
        copiedCount = copiedCount + 1
        '已复制满3条时提前终止循环
        If copiedCount = 3 Then Exit For
    Next k
NextSheet:
Next j

关键修改点 #

• 修正变量类型：将存储行号的FirstLine、NewestEntry改为Long类型，避免整数溢出、类型不匹配问题
• 增加方法容错：捕获SpecialCells无匹配结果的报错，避免空表场景下程序崩溃
• 前置空表判断：提前识别仅含表头的空工作表，直接填入提示文本后跳过后续取数逻辑
• 修正分支顺序：检测到表头时先填充"No Write Up"提示，再通过Exit For直接终止循环，不会执行无效的单元格访问
• 增加边界校验：循环中判断行号小于1时直接退出，避免访问不存在的行触发1004错误
• 增加复制计数：取满3条有效记录后提前终止循环，减少无效遍历

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