Using collection instead of array

[tiredofit]

I have 10 rows of data in column A.

I can calculate the upper quartile as follows:

Dim MyArray() As Variant

MyArray() = Cells(1, 1).CurrentRegion.Value

Dim UQ As Double

UQ = Application.WorksheetFunction.Quartile_Exc(MyArray(), 3)

If instead of using an array, I choose to use a collection, like this:

Dim MyColl As Collection
Set MyColl = New Collection

Dim Counter As Integer

For Counter = 1 to 10

    MyColl.Add Cells (Counter, 1).Value

Next Counter

Dim UQ As Double

UQ = Application.WorksheetFunction.Quartile_Exc(MyColl, 3)​

it does not work and fails on this line:

UQ = Application.WorksheetFunction.Quartile_Exc(MyColl, 3)<strike>

</strike><strike>

_^</strike>
​

I assume the reason is the first argument of Quartile_Exc expects an array? So does that defeat the object of using a collection instead of an array?

Thanks

 

[RoryA]

You'd have to create an array (or populate cells) for it to work, so I don't see the point in using a collection at all.

 

[tiredofit]

Thanks.

Using arrays only, I was declaring a dynamic array that was far bigger than what I needed (I tend not to use Redim preserve).

 

[RoryA]

You haven't provided any real info as to why, but generally you can either determine the necessary size at the start, or just use one Redim Preserve at the end.

 

[tiredofit]

You haven't provided any real info as to why, but generally you can either determine the necessary size at the start, or just use one Redim Preserve at the end.

I have two columns of data: column A is Name, column B is Amount.

I want to create the LQ and UQ metrics on the set of data where the Name is the same, hence I used a SubArray but I don't know how large it's going to be, I have declared it as big as the original data.

This algorithm works EXCEPT for a small point: If the last value in the data is an outlier, it won't identify it, probably because my loop goes from the Start to the End - 1.

How can I correct it?

For example, if my data was:

Name    Amount

a          2
a          2
a          2
a          2
a          20

LQ = 2, UQ = 11 and clearly the last value (20) is an outlier but the code won't pick it up.

Here's the full code:​

Option Explicit

    Dim DataArray() As Variant
    
    DataArray() = Sheet1.Cells(1, 1).CurrentRegion.Value
    
    Dim DataArrayRows As Double
    
    DataArrayRows = UBound(DataArray(), 1)
    
    Dim DataArrayCols As Integer
    
    DataArrayCols = UBound(DataArray(), 2)
    
    Dim SubArray() As Variant
    
    ReDim SubArray(1 To DataArrayRows, 1 To 1) As Variant
    
    Dim TempArray() As Variant
    
    ReDim TempArray(1 To DataArrayRows, 1 To 2) As Variant
    
    Dim DataArrayRowCount As Integer, SubArrayRowCount As Integer, SameNumberCount As Integer, SameNumberStartRow As Long, SameNumberBlock As Long, TempArrayRow As Integer, DataArrayColCount As Integer
    
    Dim LowerQuartile As Double, UpperQuartile As Double
    
    Dim IQR As Double
    
    SameNumberStartRow = 2
    
    TempArrayRow = 1
    
    For DataArrayRowCount = 2 To DataArrayRows - 1
                
        SubArrayRowCount = 1
        
        SameNumberCount = 1
        
        Do Until DataArray(DataArrayRowCount, 1) <> DataArray(DataArrayRowCount + 1, 1)
            
            SubArray(SubArrayRowCount, 1) = DataArray(DataArrayRowCount, 2)
            
            SameNumberCount = SameNumberCount + 1
            
            DataArrayRowCount = DataArrayRowCount + 1
            
            SubArrayRowCount = SubArrayRowCount + 1
            
            If DataArrayRowCount > DataArrayRows - 1 Then Exit Do
            
        Loop
        
        SubArray(SubArrayRowCount, 1) = DataArray(DataArrayRowCount, 2)
        
        If SameNumberCount > 2 Then
        
            With Application.WorksheetFunction
    
                LowerQuartile = .Quartile_Exc(SubArray(), 1)
                UpperQuartile = .Quartile_Exc(SubArray(), 3)
    
                IQR = UpperQuartile - LowerQuartile
    
            End With
            
            For SameNumberBlock = SameNumberStartRow To DataArrayRowCount
            
                If DataArray(SameNumberBlock, 2) < LowerQuartile - IQR * 1.5 Or _
                   DataArray(SameNumberBlock, 2) > UpperQuartile + IQR * 1.5 Then
                    TempArray(TempArrayRow, 1) = DataArray(SameNumberBlock, 1)
                    TempArray(TempArrayRow, 2) = DataArray(SameNumberBlock, 2)
                    
                    TempArrayRow = TempArrayRow + 1
                    
                    For DataArrayColCount = 1 To DataArrayCols
                    
                        DataArray(SameNumberBlock, DataArrayColCount) = vbNullString
                        
                    Next DataArrayColCount
                    
                End If
                
            Next SameNumberBlock
            
        End If
        
        ReDim SubArray(1 To DataArrayRows, 1 To 1) As Variant
        
        SameNumberStartRow = DataArrayRowCount + 1
        
    Next DataArrayRowCount
    
    Sheet1.Cells(1, 13).Resize(DataArrayRows, DataArrayCols).Value = DataArray()
    
    Erase DataArray()
    
    Erase SubArray()
    
    Erase TempArray()

 

[RoryA]

I don't have time to go through all of that but at a quick glance it looks like you'd be better off using a Dictionary to hold arrays of data for each name. You can either resize the arrays as you go, at the end, or use Countif to figure out how many items there are for each name.

 

[tiredofit]

Thanks for the tip.