结合以创建带有值的范围

Question

目标是根据某些条件，将数据从一个工作簿复制到另一个工作簿。

我对如何使此代码有效，而不是任何解决方法感兴趣。

我可以使用Range.Copy方法来做到这一点，但是我想避免使用剪贴板，因为多达70列的数据行可以多达数千行。

代码的版本稍有不同。

第一个正常运行的版本：

Sub SortByDebitor()

Dim wbSource As Workbook
Set wbSource = ActiveWorkbook
Dim lastRow As Long
Dim checkedCell As Range
Dim rng As Range
Dim list As Range
Dim wkb() As Workbook
Dim i As Integer
Dim j As Integer
Dim debitors As Variant
Dim totalDebitors As Long

'Populate array of debitors'
With wbSource
    .Worksheets.Add After:=.Sheets(Worksheets.Count)
    .Sheets(1).Range("A2:A" & Rows.Count).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Worksheets(Worksheets.Count).Range("A1"), unique:=True
End With

totalDebitors = Rows(Rows.Count).End(xlUp).Row - 1
debitors = Range(Cells(2, 1), Cells(totalDebitors + 1, 1)).Value
Worksheets(Worksheets.Count).Delete
ReDim wkb(1 To totalDebitors)

'Loop through debitors'
For i = 1 To totalDebitors

    'Loop through worksheets 1 to 3'
    For j = 1 To 3

        'Declare range for data'
        lastRow = wbSource.Sheets(j).Range("A" & Rows.Count).End(xlUp).Row
        Set list = wbSource.Sheets(j).Range("A3:A" & lastRow)

        'Check debitors and add to selection in case of match'
        For Each checkedCell In list
            If checkedCell.Value = debitors(i, 1) Then
                If rng Is Nothing Then
                    Set rng = Range("A" & checkedCell.Row & ":BX" & checkedCell.Row)
                Else
                    Set rng = Union(rng, Range("A" & checkedCell.Row & ":BX" & checkedCell.Row))
                End If
            End If
        Next
        If Not rng Is Nothing Then

            'Create workbooks and worksheets if necessary'
            If wkb(i) Is Nothing Then
                Set wkb(i) = Workbooks.Add
            Else
                wkb(i).Worksheets.Add After:=Worksheets(Worksheets.Count)
            End If

            Dim wsName As String
            wkb(i).Worksheets(Worksheets.Count).Name = wbSource.Worksheets(j).Name

            'Copy table header row'
            wbSource.Sheets(j).Cells(2, 1).EntireRow.Copy _
                Destination:=wkb(i).Sheets(Worksheets.Count).Range("A1")
            'Copy list of debitors'
            rng.Copy _
                Destination:=wkb(i).Sheets(Worksheets.Count).Range("A2")

            Set rng = Nothing

            Application.CutCopyMode = False
        End If
    Next j
Next i
End Sub

在这里，每次运行Set rng = Union(rng, Range("A" & checkedCell.Row & ":BX" & checkedCell.Row))行时，rng.Address都会正确更新，并且rng.Cells.Value会相应地更改。换句话说，在完成for循环之后，我可以提取通过Union方法添加到范围中的所有行。

无法正常工作的第二个版本：

Sub SortRowsByDebitor()

Dim wbSource As Workbook
Set wbSource = ActiveWorkbook

'Populate array of debitors'
With wbSource
    .Worksheets.Add After:=.Sheets(Worksheets.Count)
    .Sheets(1).Range("A2:A" & Rows.Count).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Worksheets(Worksheets.Count).Range("A1"), unique:=True
End With

Dim debitors As Variant
Dim totalDebitors As Long
Dim lastRow As Long
Dim lastColumn As Long
Dim lastColumnLetter As String
Dim j As Long
Dim debitor As Variant
Dim rng As Range
Dim checkedCell As Range
Dim list As Range

totalDebitors = Rows(Rows.Count).End(xlUp).Row - 1
debitors = Range(Cells(2, 1), Cells(totalDebitors + 1, 1)).Value
Worksheets(Worksheets.Count).Delete

For Each debitor In debitors

    For j = 1 To 3
        lastRow = wbSource.Sheets(j).Range("A" & Rows.Count).End(xlUp).Row
        lastColumn = wbSource.Sheets(j).Cells(2, Columns.Count).End(xlToLeft).Column
        lastColumnLetter = Split(Cells(2, lastColumn).Address, "$")(1)

        Set list = wbSource.Sheets(j).Range("A3:A" & lastRow)

        For Each checkedCell In list
            If checkedCell.Value = debitor Then
                If rng Is Nothing Then
                    Set rng = Range("A" & checkedCell.Row & ":" & lastColumnLetter & checkedCell.Row)
                Else
                    Set rng = Union(rng, Range("A" & checkedCell.Row & ":" & lastColumnLetter & checkedCell.Row))
                End If
            End If
        Next

        If Not rng Is Nothing Then

            If j = 1 Then
                Set wkb = Workbooks.Add
            Else
                wkb.Worksheets.Add After:=wkb.Worksheets(Worksheets.Count)
            End If

            wbSource.Sheets(j).Cells(2, 1).EntireRow.Copy _
              Destination:=wkb.Sheets(j).Range("A1")

            With wkb.Sheets(j)
                .Name = wbSource.Sheets(j).Name
                .Range("A2").Resize(rng.Rows.Count, rng.Columns.Count).Cells.Value = rng.Cells.Value
                .Columns("A:BR").AutoFit
                'format columns'
            End With

        End If
        'Set rng = Nothing

    Next j
Next
End Sub

问题：使用错误的代码时，Union方法正确添加了有问题的范围（如rng.Address的观察者所示，但我无法提取第一行以外的单元格值，换句话说，rng.Cells.Value显示为Variant，其中只有一项（即第一行）。