Question

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

第一列只能有六个不同的值之一（CAT1..CAT6）。

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

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

代码就是这样： Sub 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

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

1 个答案: