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

 

[rkaczano]

Really strange. The Immediate Window does show the results of the fist Debut.Print stmt (i.e. 282|6). But it is failing on the first transpose function AND I cannot seem to trap the error. The Error handler Goes to the line "eh:" but it does not print the error code to my immediate window. I used code tags on this post.

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)
    On Error GoTo eh
    
        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
    
    Debug.Print UBound(w, 1) & "|" & UBound(w, 2)
    
    w = WorksheetFunction.Transpose(w)
    
    ReDim Preserve w(1 To 6, 1 To j)
    
    w = WorksheetFunction.Transpose(w)
    Debug.Print UBound(w, 1) & "|" & UBound(w, 2)
    
    ConsolidateArrayRows = w
  
eh:
      Debug.Print "An error occurred on line: " & Erl 
  
End Function

 

[AlphaFrog]

Did you try it as I submitted? Application.Transpose
Yours is not the same.

Well done with the CODE tags.

 

[rkaczano]

Yes I did try that.

It fails on the Application.transpose line . It take right out of the function and also right out of subtroutine that that function is called in. And I cannot get it to trap the error. The reason I had changed it was higher up in the code I am using WorksheetFunction.IfError. I thought the syntax differences were causing the errors - but that does not seem to be the case.

In the Immediate Window I can test the array w as follows below right before the the code fails on the Application.transpose line. Clearly the array w is populated and clearly it has 284 rows and 6 columns.

I am at a loss at the moment...


?w(1,1)
AFG1
?Ubound(w,1)
284
?Ubound(w,2)
6

 

[AlphaFrog]

This is a guess. If the array contains Null values, the transpose function errors according to this

VBA Arrays - Transposing

VBA Reference - Microsoft Office Add-ins and Consultancy. One website for all Microsoft Office Users and Developers.

bettersolutions.com

Try changing this...
w(j, 3) = Null

To this...
w(j, 3) = ""

 

[rkaczano]

When using "NULL" the loop completely finishes (283 loops) and the code fails on Application. The Error is Runtime Error 13 Type Mismatch.

When "" instead of "NULL" it fails on the 49th loop. Runtime Error 13 Type Mismatch.

It fails on this line of code:
w(j, 3) = WorksheetFunction.IfError((w(j, 3) * w(j, 2) + v(i, 3) * v(i, 2)) / (w(j, 2) + v(i, 2)), 0)

w(j, 3) inside the IfError function has a value of "". This creates a type mismatch

The "" value for w(j, 3) is from a previous iteration of the loop.

IMMEDIATE WINDOW
?V(i,1) & "|" & V(i,2) & "|" & V(i,3) & "|" & V(i,4) & "|" & V(i,5) & "|" & V(i,6)
BSC1|-0.0195|5|0|Type1|13

?(w(j, 3) & "*" & w(j, 2) & "+" & v(i, 3) & "*" & v(i, 2)) & "/" & (w(j, 2) & "+" & v(i, 2))
"" * 0 + 5 * -0.0195/0 + -0.0195

?WorksheetFunction.IfError((w(j, 3) * w(j, 2) + v(i, 3) * v(i, 2)) / (w(j, 2) + v(i, 2)), 0)
Runtime Error 13 Type Mismatch

 

[AlphaFrog]

Try...
w(j, 3) = 0

 

[rkaczano]

yup that worked.

Thanks for your help on this!