按参数向多目标工作表传输数据时的空范围问题排查

我原本实现了向单个目标工作表传输数据的VBA代码，运行正常，但添加第二个目标工作表后，出现待复制范围为空的问题，无法定位错误原因。以下是相关代码及解决方案：

可正常运行的单目标工作表代码 #

Sub DealerRules() 'Working
    Dim r As Long, wsTarget As Worksheet, cel As Range

    r = 3
    With ThisWorkbook
        Set wsTarget = .Sheets("LXXXXXXB-LXXXXXXT")
        With .ActiveSheet
            For Each cel In .Range("B3:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Cells
                If cel.Value = 1 Or cel.Value = 2 Then
                    .Range(cel.Offset(, -1).Address & ":Q" & cel.Row).Copy Destination:=wsTarget.Range("A" & r & ":Q" & r)
                    r = r + 1
                End If
            Next
        End With
    End With
End Sub

添加第二个目标后无法工作的代码（待复制数据为空） #

Sub DealerRules()
    Dim r1 As Long, r2 As Long, wsTarget1 As Worksheet, wsTarget2 As Worksheet, cel As Range, dataToCopy As Variant

    r1 = 3 ' 第一个目标表从第3行开始
    r2 = 3 ' 第二个目标表从第3行开始
    With ThisWorkbook
        Set wsTarget1 = .Sheets("LXXXXXXB-LXXXXXXT")
        Set wsTarget2 = .Sheets("LXXXXXXB-LXXXXXXO")
        With .Sheets("LXXXXXXB RAW") ' 指定数据源工作表
            For Each cel In .Range("B3:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Cells
                If Left(cel.Offset(, -1).Value, 5) = "101.18" And (cel.Value = 1 Or cel.Value = 2) Then
                   dataToCopy = .Range(cel.Offset(, -1).Address & ":Q" & cel.Row).Value  ' 原复制语句被注释
                   If Not IsEmpty(dataToCopy) Then
                   wsTarget1.Range("A" & r1 & ":Q" & r1).Value = dataToCopy
                    r1 = r1 + 1
                    End If
                ElseIf Left(cel.Offset(, -1).Value, 5) = "101.19" And (cel.Value = 1 Or cel.Value = 2) Then
                    dataToCopy = .Range(cel.Offset(, -1).Address & ":Q" & cel.Row).Value  ' 原复制语句被注释
                    If Not IsEmpty(dataToCopy) Then
                    wsTarget2.Range("A" & r2 & ":Q" & r2).Value = dataToCopy
                    r2 = r2 + 1
                End If
                End If
            Next
        End With
    End With
End Sub

错误原因与修复方案 #

关键错误点 #

1. 数值类型适配问题：Left(cel.Offset(, -1).Value,5) 中，若A列单元格是数值类型（比如101.18是数字格式），Left函数无法直接处理数值，会导致条件判断失效，代码不会进入复制逻辑。
2. 范围地址拼接冗余：cel.Offset(, -1).Address 返回的是绝对地址（如$A$3），拼接成范围字符串容易出现潜在问题，直接用单元格对象定义范围更可靠。
3. 空值判断逻辑无效：IsEmpty(dataToCopy) 对数组类型变量判断无效——当把单元格范围赋值给变体变量时，即使单元格为空，变量也会变成二维数组，不会处于Empty状态，导致判断逻辑错误。

修复后的代码 #

Sub DealerRules()
    Dim r1 As Long, r2 As Long, wsTarget1 As Worksheet, wsTarget2 As Worksheet, cel As Range
    Dim sourceRange As Range
    
    r1 = 3
    r2 = 3
    With ThisWorkbook
        Set wsTarget1 = .Sheets("LXXXXXXB-LXXXXXXT")
        Set wsTarget2 = .Sheets("LXXXXXXB-LXXXXXXO")
        With .Sheets("LXXXXXXB RAW")
            ' 遍历B列有数据的行
            For Each cel In .Range("B3:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Cells
                ' 直接定义当前行A到Q列的复制范围
                Set sourceRange = .Range(.Cells(cel.Row, "A"), .Cells(cel.Row, "Q"))
                
                ' 先判断B列值，再判断A列前缀（转字符串避免数值类型错误）
                If (cel.Value = 1 Or cel.Value = 2) Then
                    Select Case Left(CStr(sourceRange.Cells(1).Value), 5)
                        Case "101.18"
                            sourceRange.Copy Destination:=wsTarget1.Range("A" & r1)
                            r1 = r1 + 1
                        Case "101.19"
                            sourceRange.Copy Destination:=wsTarget2.Range("A" & r2)
                            r2 = r2 + 1
                    End Select
                End If
            Next cel
        End With
    End With
End Sub

修复说明 #

• 用CStr()将A列单元格值转为字符串，确保Left函数能正常提取前缀。
• 直接通过Cells对象定义复制范围，避免地址拼接的潜在错误。
• 调整条件判断结构，先统一判断B列值，再用Select Case区分A列前缀，逻辑更清晰；恢复使用Copy方法直接复制，省去无效的中间变量和空值判断。

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