通过参数将数据传输到多个目标工作表

Question

我有一个单一目标工作表正在运行，但是当我添加第二个目标时，范围显示什么都没有，我不知道我做错了什么。

单个目标的工作代码

        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 ' Start from row 3 in the first target sheet
            r2 = 3 ' Start from row 3 in the second target sheet
            With ThisWorkbook
                Set wsTarget1 = .Sheets("LXXXXXXB-LXXXXXXT")
                Set wsTarget2 = .Sheets("LXXXXXXB-LXXXXXXO")
                With .Sheets("LXXXXXXB RAW") 'Sets the Activesheet
                    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  'Copy Destination:=wsTarget1.Range("A" & r1 & ":Q" & r1)
                           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  '.Range(cel.Offset(, -1).Address & ":Q" & cel.Row).Copy Destination:=wsTarget2.Range("A" & r2 & ":Q" & r2)
                            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

我尝试过很多不同的失败方法。我希望能流利地说 VBA 的人可以提供帮助。

Answer 1

在您的原始代码中，

Left(cel.Offset(, -1).Value, 5) = "101.19"

永远不会是

TRUE

，因为“101.19”有六个字符长，而您只查看前五个字符。 将来尝试使用调试器逐行单步调试代码，它有助于捕获这些简单的错误。

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

    r1 = 3 ' Start from row 3 in the first target sheet
    r2 = 3 ' Start from row 3 in the second target sheet
    
    Set wsTarget1 = ThisWorkbook.Sheets("LXXXXXXB-LXXXXXXT")
    Set wsTarget2 = ThisWorkbook.Sheets("LXXXXXXB-LXXXXXXO")
    
    With ThisWorkbook.Sheets("LXXXXXXB RAW") ' Active sheet
        For Each cel In .Range("B3:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
            If (cel.Value = 1 Or cel.Value = 2) Then
                If Left(cel.Offset(, -1).Value, 6) = "101.18" Then
                    CopyData cel, wsTarget1, r1
                    r1 = r1 + 1
                ElseIf Left(cel.Offset(, -1).Value, 6) = "101.19" Then
                    CopyData cel, wsTarget2, r2
                    r2 = r2 + 1
                End If
            End If
        Next cel
    End With
End Sub

Sub CopyData(cel As Range, wsTarget As Worksheet, targetRow As Long)
    Dim dataToCopy As Variant
    dataToCopy = cel.Offset(, -1).Resize(, 17).Value ' Copy range from column A to Q
    If Not IsEmpty(dataToCopy) Then
        wsTarget.Range("A" & targetRow & ":Q" & targetRow).Value = dataToCopy
    End If
End Sub