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

#### rkaczano

##### Board Regular
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

### 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
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
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
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

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
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

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
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
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
@ AlphaFrog
"because I used CODE tags"

Replies
3
Views
129
Replies
4
Views
119
Replies
1
Views
52
Replies
1
Views
162
Replies
5
Views
312

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