VBA Excel - Range in Variant split by content criteria - excel

Question

I have a very large data block in an excel spreadsheet (100,000 rows by 30 columns).
The first column can have one of only six different values (CAT1..CAT6).
I need to split the content in 6 spreadsheets in the same book.
I load the source range in a source variant and split it in target variant, which I write in target sheets.
Code is along this lines:
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
Now for the questions:
Is there a way to copy one "row" at a time from the source variant to the target variant? Something like
b(j,) = a(i,)
Is there a way to simply redim the target variants to the data content (initially I just DIM to match the source but each target variant will obiously have less content than the source
Is there any other approach to the split problem more efficient? (collections? keys?)
Any suggestions will be most appreciated.
Thanks for reading
Cris

Answer 1

a combination of Sort() and Autofilter() methods of Range object should be quite fast:
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