VBA Dynamic Array - ReDim

[bkapadia]

Have a spreadsheet with two columns. Parse data, both the # & letters; then output onto bucketed i.e. 1-100 tab w/corresponding letter/

[TABLE="width: 199"]
<tbody>[TR]
[TD]7.259764189[/TD]
[TD]a[/TD]
[/TR]
[TR]
[TD]271.7909785[/TD]
[TD]b[/TD]
[/TR]
[TR]
[TD]69.12924367[/TD]
[TD]c[/TD]
[/TR]
[TR]
[TD]...[/TD]
[TD]...[/TD]
[/TR]
</tbody>[/TABLE]

Writing VBA code (even though this could be done manually) so that the numbers are bucketed:

• 1-100;
• 101-200;
• 201-300 etc

So, # & corresponding letters should go on to they're respective bucketed tab within the same workbook.

I know how do to the bucketing for numbers, but unable to figure out how to include corresponding column B(letters)?

Any ideas on expanding the code to incorporate column B?

* * * * *
* * * * *

VBA CODE:

Sub Dynamic()


Dim ARRAY100() As Variant
Dim ARRAY200() As Variant
Dim ARRAY300() As Variant
Dim ARRAY400() As Variant


Dim Counter As Integer

Dim Index1 As Integer
Dim Index2 As Integer
Dim Index3 As Integer
Dim Index4 As Integer

Dim Data As Double
Dim Destination As Range



Counter = 0

Index1 = 1
Index2 = 1
Index3 = 1
Index4 = 1


Sheets("rawdata").Select
Range("A1").Select

Do Until ActiveCell.Offset(Counter, 0) =
Data = ActiveCell.Offset(Counter, 0)

Select Case Data


Case 0 To 100
ReDim Preserve ARRAY100(1 To Index1, 1 To 2)
ARRAY100(Index1, 1 To Index2, 2) = ActiveCell.Offset(Counter)
Index1 = Index1 + 1

Case 101 To 200
ReDim Preserve ARRAY200(1 To Index2)
ARRAY200(Index2) = ActiveCell.Offset(Counter)
Index2 = Index2 + 1

Case 201 To 300
ReDim Preserve ARRAY300(1 To Index3)
ARRAY300(Index3) = ActiveCell.Offset(Counter)
Index3 = Index3 + 1

Case 301 To 400
ReDim Preserve ARRAY400(1 To Index4)
ARRAY400(Index4) = ActiveCell.Offset(Counter)
Index4 = Index4 + 1

End Select


Counter = Counter + 1

Loop


'write array to tab100
Set Destination = Sheets("Tab100").Range("A1")
Set Destination = Destination.Resize(UBound(ARRAY100), 1)
Destination.Value = WorksheetFunction.Transpose(ARRAY100)


'write array to tab200
Set Destination = Sheets("Tab200").Range("A1")
Set Destination = Destination.Resize(UBound(ARRAY200), 1)
Destination.Value = WorksheetFunction.Transpose(ARRAY200)

'write array to tab300
Set Destination = Sheets("Tab300").Range("A1")
Set Destination = Destination.Resize(UBound(ARRAY300), 1)
Destination.Value = WorksheetFunction.Transpose(ARRAY300)


'write array to tab400
Set Destination = Sheets("Tab400").Range("A1")
Set Destination = Destination.Resize(UBound(ARRAY400), 1)
Destination.Value = WorksheetFunction.Transpose(ARRAY400)




End Sub

 

[JoeMo]

Maybe better to use 2-D arrays and "over-dimension" them once rather then repeatedly doing a Redim. The code below assumes your initial data begin in cell A2 - change cell address to suit.

Sub NumbersToBuckets()
Dim lR As Long, R As Range, vA As Variant, i As Long
Dim T1(), T2(), T3(), T4()
Dim Ct1 As Long, Ct2 As Long, Ct3 As Long, Ct4 As Long, Rws As Long

lR = Range("A" & Rows.Count).End(xlUp).Row
Set R = Range("A2:B" & lR)
vA = R.Value
ReDim T1(1 To UBound(vA, 1), 1 To 2)
ReDim T2(1 To UBound(vA, 1), 1 To 2)
ReDim T3(1 To UBound(vA, 1), 1 To 2)
ReDim T4(1 To UBound(vA, 1), 1 To 2)
For i = LBound(vA, 1) To UBound(vA, 1)
    Select Case vA(i, 1)
        Case 0 To 100
            Ct1 = Ct1 + 1
'            ReDim Preserve T1(1 To Ct1, 1 To 2)
            T1(Ct1, 1) = vA(i, 1)
            T1(Ct1, 2) = vA(i, 2)
        Case 101 To 200
            Ct2 = Ct2 + 1
'            ReDim Preserve T2(1 To Ct2, 1 To 2)
            T2(Ct2, 1) = vA(i, 1)
            T2(Ct2, 2) = vA(i, 2)
        Case 201 To 300
            Ct3 = Ct3 + 1
'            ReDim Preserve T3(1 To Ct3, 1 To 2)
            T3(Ct3, 1) = vA(i, 1)
            T3(Ct3, 2) = vA(i, 2)
        Case 301 To 400
            Ct4 = Ct4 + 1
'            ReDim Preserve T4(1 To Ct4, 1 To 2)
            T4(Ct4, 1) = vA(i, 1)
            T4(Ct4, 2) = vA(i, 2)
    End Select
Next i
If Ct1 >= 1 Then
    With Sheets("Tab100").Range("A1")
        .Resize(Ct1, 2).Value = T1
    End With
End If
If Ct2 >= 1 Then
    With Sheets("Tab200").Range("A1")
        .Resize(Ct2, 2).Value = T2
    End With
End If
If Ct3 >= 1 Then
    With Sheets("Tab300").Range("A1")
        .Resize(Ct3, 2).Value = T3
    End With
End If
If Ct4 >= 1 Then
    With Sheets("Tab400").Range("A1")
        .Resize(Ct4, 2).Value = T4
    End With
End If
End Sub