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

现在回答问题：

• 有没有办法一次将一个“行”从源变体复制到目标变体？类似的东西

  b(j,) = a(i,)

• 有没有办法简单地将目标变体重新调整为数据内容（最初我只是 DIM 以匹配源，但每个目标变体的内容显然都比源少

• 还有其他更有效的分割问题方法吗？ （收藏？钥匙？）

任何建议将不胜感激。

感谢阅读

危机

Answer 1

Range 对象的 Sort() 和 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