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

rkaczano

Board Regular
Joined
Jul 24, 2013
Messages
77
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
 

Some videos you may like

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,358
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:

VBA Code:
    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

Board Regular
Joined
Jul 24, 2013
Messages
77
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

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,358
VBA Code:
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

Board Regular
Joined
Jul 24, 2013
Messages
77

ADVERTISEMENT

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

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,358
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.

VBA Code:
    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

Board Regular
Joined
Jul 24, 2013
Messages
77

ADVERTISEMENT

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

Board Regular
Joined
Jul 24, 2013
Messages
77
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

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,358
This worked for me. And it's easily readable because I used CODE tags.

VBA Code:
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

Well-known Member
Joined
Sep 5, 2004
Messages
1,671
Office Version
  1. 2013
  2. 2007
Platform
  1. Windows
@ AlphaFrog
"because I used CODE tags" (y)(y)
 

Watch MrExcel Video

Forum statistics

Threads
1,118,813
Messages
5,574,483
Members
412,596
Latest member
nickthebizz
Top