首页 文章

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

提问于
浏览 次
0

我在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以匹配源，但每个目标变体的内容将比源更少

  • 有没有其他方法可以提高分割问题的效率？ （集合？键？）

任何建议将非常感谢 .

谢谢阅读

克里斯

excel vba variant

1 回答

  • 0

    对象的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
    回复于

相关问题