VBA Excel - 变体中的范围按内容标准拆分

Question

我在 excel 电子表格中有一个非常大的数据块（100,000 行 x 30 列）。

第一列只能有六个不同值之一 (CAT1..CAT6)。

我需要在同一本书的 6 个电子表格中拆分内容。

我在源变体中加载源范围并将其拆分为目标变体，我将其写入目标工作表。

代码是这样的：子 TestVariant()

Dim a, b, c As Variant
Dim i, j, k As Variant

Worksheets("Sheet1").Activate

a = Worksheets("Sheet1").Range("A1:AD100000").Value

ReDim b(UBound(a, 1), UBound(a, 2))
ReDim c(UBound(a, 1), UBound(a, 2))

j = 1
k = 1

For i = 1 To UBound(a, 1)
Select Case a(i, 1)
    Case "CAT01"
        b(j, 1) = a(i, 1)
        '..
        b(j, 30) = a(i, 30)
        j = j + 1
    Case Else
        c(k, 1) = a(i, 1)
        '..
        c(k, 30) = a(i, 30)
        k = k + 1
    End Select
Next i

Worksheets("Sheet2").Range("A1").Resize(UBound(b, 1), UBound(b, 2)) = b
Worksheets("Sheet3").Range("A1").Resize(UBound(c, 1), UBound(c, 2)) = c

End Sub

现在开始提问：

有没有办法从源变体一次复制一个"row"到目标变体？像

b(j,) = a(i,)
有没有办法简单地将目标变体重新调整为数据内容（最初我只是 DIM 以匹配源，但每个目标变体的内容都比源少
有没有其他方法可以更有效地解决拆分问题？ (collections?键?)

如有任何建议，我们将不胜感激。

感谢阅读

克里斯

Answer 1

Range 对象的 Sort() and Autofilter() 方法的组合应该相当快：

Option Explicit

Sub TestVariant()
    Dim iCat As Long

    With Worksheets("Sheet1")
        With .Range("AD1", .Cells(.Rows.COUNT, 1).End(xlUp))
            .Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes ', SortMethod:=xlPinYin, DataOption1:=xlSortNormal, MatchCase:=False, Orientation:=xlTopToBottom
            For iCat = 1 To 6
                .AutoFilter Field:=1, Criteria1:="CAT0" & iCat '<--| filter its columns A on current "CAT"
                If Application.WorksheetFunction.Subtotal(103, .Columns(1).Cells) > 1 Then '<--| if any cell filtered other than header
                    With .Offset(1).Resize(.Rows.COUNT - 1).SpecialCells(xlCellTypeVisible)
                        GetWorkSheet("CAT0" & iCat).Range("A1").Resize(.Rows.COUNT, .Columns.COUNT).Value = .Value
                    End With
                End If
            Next iCat
        End With
        .AutoFilterMode = False
    End With
End Sub

Function GetWorkSheet(shtName As String) As Worksheet
    On Error Resume Next
    Set GetWorkSheet = Worksheets(shtName)
    If GetWorkSheet Is Nothing Then
        Set GetWorkSheet = Worksheets.Add
        GetWorkSheet.name = shtName
    End If
End Function

VBA Excel - 变体中的范围按内容标准拆分

VBA Excel - Range in Variant split by content criteria

excel

vba

variant