Optimising loop

[tiredofit]

I have some data consisting of two columns, for example:

Name    Amount
a           100
a           200 
a           300
b           20
b           50
b           60

I want to calculate the Lower Quartile for every "block". By block I mean where the name is the same (ie in the sample above, I want to return a quartile value for a (= 100) and a quartile value for b (= 30).

This is my code (which works):

    Dim DataArray() As Variant
    
    DataArray() = wksData.Cells(1, 1).CurrentRegion.Value
    
    Dim DataArrayRows As Long
    
    DataArrayRows = UBound(DataArray(), 1)
    
    Dim AmountArray() As Variant
    ReDim AmountArray(1 To DataArrayRows, 1 To 1) As Variant
    
    Dim AmountQArray() As Variant
    
    ReDim AmountQArray(1 To DataArrayRows, 1 To 1) As Variant
    
    Dim Counter As Long
    
    For Counter = 2 To DataArrayRows - 1
        
        AmountArray(Counter, 1) = DataArray(Counter, 2)
        
        If DataArray(Counter, 1) <> DataArray(Counter + 1, 1) Then
        
            On Error Resume Next
                AmountQArray(Counter, 1) = Application.WorksheetFunction.Quartile_Exc(AmountArray(), 1)
            On Error GoTo 0
        
            ReDim AmountArray(1 To DataArrayRows, 1 To 1) As Variant
        
        End If
        
        If Counter = DataArrayRows - 1 Then
            Counter = Counter + 1
            AmountArray(Counter, 1) = DataArray(Counter, 2)
            AmountQArray(Counter, 1) = Application.WorksheetFunction.Quartile_Exc(amountArray(), 1)
            ReDim AmountArray(1 To DataArrayRows, 1 To 1) As Variant
        End If
        
    Next Counter
    
    wksData.Cells(1, 5).Resize(DataArrayRows, 1).Value = AmountQArray()

The problem is I have LOTS of data (about 1m rows) and the code above is slow (after 15 miuntes, it still hasn't finished running).

How can I speed things up?

Thanks

 

[Jerry Sullivan]

Your existing code uses the same number of rows (~1 M) for AmountArray as it does for the input and results arrays. That uses a lot more memory than needed for rediming AmountArray and calculating its 1st quartile. I understand that you've done that because you don't know in advance how many rows will be needed for AmountArray, so you are using the maximum possible.

Assuming the maximum rows in a block are just a small fraction of the total rows of data, the code can be sped up significantly by first finding the maximum rows in a block, then using that as the upper bound for AmountArray.

Sub GetQuartilesByBlock()
 Dim CounterAll As Long, CounterThisName As Long
 Dim DataArrayRows As Long, MaxRecordCount As Long
 Dim AmountArray() As Variant
 Dim AmountQArray() As Variant
 Dim DataArray() As Variant

 DataArray() = wksData.Cells(1, 1).CurrentRegion.Value
 DataArrayRows = UBound(DataArray(), 1)

 ReDim AmountQArray(1 To DataArrayRows, 1 To 1) As Variant

 MaxRecordCount = lGetMaxRecords(vArray:=DataArray)
 ReDim AmountArray(1 To MaxRecordCount, 1 To 1) As Variant
 
 For CounterAll = 2 To DataArrayRows - 1
   CounterThisName = CounterThisName + 1
    
   AmountArray(CounterThisName, 1) = DataArray(CounterAll, 2)
   
   If DataArray(CounterAll, 1) <> DataArray(CounterAll + 1, 1) Then
      On Error Resume Next
         AmountQArray(CounterAll, 1) = Application.Quartile_Exc(AmountArray(), 1)
         If Err.Number <> 0 Then
            AmountQArray(CounterAll, 1) = "#N/A"
         End If
      On Error GoTo 0
   
      CounterThisName = 0 'reset
      ReDim AmountArray(1 To MaxRecordCount, 1 To 1) As Variant
   End If
        
   If CounterAll = DataArrayRows - 1 Then
      CounterThisName = CounterThisName + 1
      AmountArray(CounterThisName, 1) = DataArray(CounterAll + 1, 2)
      
      On Error Resume Next
         AmountQArray(CounterAll + 1, 1) = Application.Quartile_Exc(AmountArray(), 1)
         If Err.Number <> 0 Then
            AmountQArray(CounterAll + 1, 1) = "#N/A"
         End If
      On Error GoTo 0
   End If
 Next CounterAll
    
 wksData.Cells(1, 5).Resize(DataArrayRows, 1).Value = AmountQArray()
End Sub

Function lGetMaxRecords(vArray As Variant) As Long
 '--assumes vArray is a 2D array that has labels in the first column
 '--returns maximuum number of sequential record labels in vArray
 
 Dim lNdx As Long, lCount As Long, lMax As Long
 
 If LBound(vArray, 1) = UBound(vArray, 1) Then
   lMax = 1
 Else
   For lNdx = LBound(vArray, 1) + 1 To UBound(vArray, 1)
      If vArray(lNdx, 1) = vArray(lNdx - 1, 1) Then
        lCount = lCount + 1
      Else
        '--change in record label
         If lCount > lMax Then lMax = lCount
         lCount = 1
      End If
   Next lNdx
   '--(re)process last label
   If lCount > lMax Then lMax = lCount
 End If

 lGetMaxRecords = lMax
End Function

In my test with 1 million rows of data, this code took about 7 seconds to complete.