Consolidate repeated items in 2D array, remove empty data, and resize array

[rkaczano]

I have a 2D array that I know will have duplicate Text items in column 1.The array is already sorted so the duplicate items will be contiguous. I will have at most 3 repeated rows and at least 2 repeated rows.

I effectively want to consolidate the repeated rows, clear values in erroneous rows, and then resize the array (i.e. delete erroneous rows). To resize the array I will pass all the non empty rows to a dictionary and then back to a new smaller array.

Most all other columns have values as numbers which I will have to sum.

I am assuming my best approach will be to identify how may first column repeats exist by doing a first pass of the array by looping and creating an index.

[1,1,1,2,2,3,3,4,4,4,5,5,6,6,6,....

or an array that highlights the position of how may rows following are associated with the given row

[3,3,3,5,5,7,7,10,10,10,12,12,15,15,15 (i.e. first three rows repeat so rows 1-3 are tied to row 3).

Then use this index while looping through the array again to start the consolidation and clearing of data.

Does this sound like the right approach and if so, any ideas on how to create the index for the first pass?

Thanks

 

[AlphaFrog]

I have a 2D array that I know will have duplicate Text items in column 1.The array is already sorted so the duplicate items will be contiguous. I will have at most 3 repeated rows and at least 2 repeated rows.

I effectively want to consolidate the repeated rows, clear values in erroneous rows, and then resize the array (i.e. delete erroneous rows). To resize the array I will pass all the non empty rows to a dictionary and then back to a new smaller array.

Most all other columns have values as numbers which I will have to sum.

What determines "erroneous rows"?

You could use the Dictionary to consolidate rows.

Example:

    Dim Dict As Object, My2DArray As Variant
        
    My2DArray = Range("A1:B10").Value
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = 1
    
    For r = LBound(My2DArray, 1) To UBound(My2DArray, 1)
        If IsNumeric(My2DArray(r, 2)) Then
            Dict.Item(My2DArray(r, 1)) = Dict.Item(My2DArray(r, 1)) + My2DArray(r, 2)
        End If
    Next r
    
    Range("C1").Resize(Dict.Count).Value = Application.Transpose(Dict.Keys)
    Range("D1").Resize(Dict.Count).Value = Application.Transpose(Dict.Items)

 

[rkaczano]

Thanks.

When I say erroneous rows I mean rows that I no longer need after I consolidate.

My 2d array actually has 6 columns of data:
- Column 1 and 5 have text that is repeated
- Column 2 needs to be summed
- Column 3 needs to be weighted based on values in Column 2
- Column 4 needs to be summed
- Column 6 needs to be summed

So the 2D array is sorted based on column 1. I will see rows that are similar based on column 1 text in the original array.

Original Array
ABC|10|6 |8 |Type1|20|
ABC|7 |8 |11|Type1|10|
ABC|3 |10|35|Type1|30|
DEF|1 |2 |8 |Type3|10|
DEF|5 |8 |11|Type3|15|
DEF|8 |3 |35|Type3|25|

Revised Array
ABC|20|7.3|8|Type1|60
DEF|14|7.568|Type3|50

 

[AlphaFrog]

Sub Consolidater()
    
    Dim v As Variant, w As Variant, i As Long, j As Long
    
    'Data
    v = Range("A1:F" & Range("A" & Rows.Count).End(xlUp).Row).Value
    ReDim w(1 To UBound(v, 1), 1 To 6)
    j = 1
        
    For i = 1 To UBound(v, 1)
        If v(i, 1) <> w(j, 1) Then
            If w(j, 1) <> Empty Then j = j + 1
            For k = 1 To 6
                w(j, k) = v(i, k)
            Next
        Else
            w(j, 3) = (w(j, 3) * w(j, 2) + v(i, 3) * v(i, 2)) / (w(j, 2) + v(i, 2))
            w(j, 2) = w(j, 2) + v(i, 2)
            w(j, 4) = w(j, 4) + v(i, 4)
            w(j, 6) = w(j, 6) + v(i, 6)
        End If
    Next i
    
    'Output
    Range("H1").Resize(j, 6).Value = w
    
End Sub

 

[rkaczano]

This works well. Thank-you.

I converted it to a function that takes an array, I had to wrap some error logic around one of the lines below in the event that column 2 had some zeros to avoid a /0 error.

I want this to take an array and pass a revised version of that array back to the sub. I noticed that the UBound(w,1) has the same number of rows at the end of the routine as UBound(v, 1) at the beginning of the routine. I want to resize w() so that there are not any empty rows in it. How do I do that?

Private Function ConsolidateArrayRows(v As Variant) As Variant
UBound(v, 1)
Dim w As Variant, i As Long, j As Long, k As Long
'Data

ReDim w(1 To , 1 To 6)
j = 1

For i = 1 To UBound(v, 1)
If v(i, 1) <> w(j, 1) Then
If w(j, 1) <> Empty Then j = j + 1
For k = 1 To 6
w(j, k) = v(i, k)
Next
Else
If w(j, 2) = 0 And v(i, 2) = 0 Then
w(j, 3) = Null
Else
w(j, 3) = WorksheetFunction.IfError((w(j, 3) * w(j, 2) + v(i, 3) * v(i, 2)) / (w(j, 2) + v(i, 2)), 0)
End If

w(j, 2) = w(j, 2) + v(i, 2)
w(j, 4) = w(j, 4) + v(i, 4)
w(j, 6) = w(j, 6) + v(i, 6)
End If
Next i

ConsolidateArrayRows = w

End Function

 

[AlphaFrog]

The last dimension of a multidimensional array is the only one that can be resized while preserving the data. So in this case; transpose the array, resize the last dimension, then transpose it again.

    w = Application.Transpose(w)
    ReDim Preserve w(1 To 6, 1 To j)
    w = Application.Transpose(w)

v v v v v v Please use CODE tags when posting your code. v v v v v v v

 

[rkaczano]

Thanks.

J = 104, but there still seems to be 282 rows in the final w (). Am I missing something here? Do I need to add:

ReDim Preserve w(1 To j, 1 To 6) to the end of the routine?

*****************
Debug.Print UBound(w, 1)

w = Application.WorksheetFunction.Transpose(w)
Debug.Print UBound(w, 1)

ReDim Preserve w(1 To 6, 1 To j)
Debug.Print j

w = Application.WorksheetFunction.Transpose(w)
Debug.Print UBound(w, 1)

IMMEDIATE WINDOW
284
284
104
284

 

[rkaczano]

Or put another way, I don't see the transpose results at all.

Debug.Print UBound(w, 1) & "|" & UBound(w, 2)

w = Application.WorksheetFunction.Transpose(w)
Debug.Print UBound(w, 1) & "|" & UBound(w, 2)

ReDim Preserve w(1 To 6, 1 To j)
Debug.Print UBound(w, 1) & "|" & UBound(w, 2)

w = Application.WorksheetFunction.Transpose(w)
Debug.Print UBound(w, 1) & "|" & UBound(w, 2)

IMMEDIATE WINDOW
282|6
282|6
282|6
282|6

 

[AlphaFrog]

This worked for me. And it's easily readable because I used CODE tags.

Private Function ConsolidateArrayRows(v As Variant) As Variant
    
    Dim w As Variant, i As Long, j As Long, k As Long
    'Data
    ReDim w(1 To UBound(v, 1), 1 To 6)
    j = 1
    
    For i = 1 To UBound(v, 1)
        If v(i, 1) <> w(j, 1) Then
            If w(j, 1) <> Empty Then j = j + 1
            For k = 1 To 6
                w(j, k) = v(i, k)
            Next
        Else
            If w(j, 2) = 0 And v(i, 2) = 0 Then
                w(j, 3) = Null
            Else
                w(j, 3) = WorksheetFunction.IfError((w(j, 3) * w(j, 2) + v(i, 3) * v(i, 2)) / (w(j, 2) + v(i, 2)), 0)
            End If
    
            w(j, 2) = w(j, 2) + v(i, 2)
            w(j, 4) = w(j, 4) + v(i, 4)
            w(j, 6) = w(j, 6) + v(i, 6)
        End If
    Next i
    
    w = Application.Transpose(w)
    ReDim Preserve w(1 To 6, 1 To j)
    w = Application.Transpose(w)
    
    ConsolidateArrayRows = w
    
End Function

 

[jolivanes]

@ AlphaFrog
"because I used CODE tags"