VBA Excel - диапазон по разности по критерию контента

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 

Теперь вопросы:

• Есть ли способ, чтобы скопировать одну «строку» в то время, от источника вариант к целевому варианту? Что-то вроде

  б (J) = A (I,)

• Есть ли способ просто Redim цели варианты к содержанию данных (изначально я просто DIM в соответствии с источником, но каждый целевым вариантом будет obiously имеет меньшее содержание, чем источник

• есть ли другой подход к проблеме раскола более эффективной? (коллекции? ключи?)

любые предложения будут оценивать.

Спасибо за чтение

Cris

Answer 1

Сочетание Sort() и Autofilter() методы Range объекта должны быть достаточно быстро:

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