VBA with removing duplicate rows, with the addition of sum and concat

[pcgfcg]

I have a data table as shown in the first picture. This is just a very small sample of the table. It would remain only this many columns wide, but it can go 100s of thousands of rows. Every so often the information will have duplicate entries like the ones highlighted. The inputs for the columns date, hr, part, prod, etc, would be the same, but the only information that will be different in these duplicate rows is the last two columns. Is there a way with VBA to find these duplicate rows from A:P removing those duplicates, while adding the different values in Q, while also combining the data in R?

I attached another picture of what a finished line would look like. Rows 7 and 8 would become one row that might look like 10.

Thank you for any assistance in learning how to do this!

 

[sijpie]

Read through the comments in the code to understand what is happening.

The code uses an input array and an output array to increase the processing speed. Reading and writing to a sheet is slow. So the code only reads once and writes once. On bbig tables this makes an enormous difference.

Option Explicit
'to force variable declaration use Option Explicit as the first line in your module
'This decreases bugs, as mistyped variables are flagged up

Sub CombineDupicates()
    Dim vIn As Variant, vOut As Variant
    Dim lRi1 As Long, lRi2 As Long, lC As Long, _
        UB1 As Long, UB2 As Long, lRo As Long, UB2Last As Long
    Dim bIdentical As Boolean
    
    'load the complete table into an array vIn. vIn then becomes like a fast sheet in memory
    vIn = Range("A1").CurrentRegion
    
    'get the nummber of rows ov vIn
    UB1 = UBound(vIn, 1)
    'and nr of columns
    UB2Last = UBound(vIn, 2)
    UB2 = UB2Last - 2   ' no need to check the last two columns
    
    'Make vOut the same size as vIn
    ReDim vOut(1 To UB1, 1 To UB2Last)
    
    'copy the header row
    For lC = 1 To UB2Last
        vOut(1, lC) = vIn(1, lC)
    Next lC
    'now loop through the rows of the table, checking each line with the line below
    'if different, then copy line to vOut
    'if the same then copy line and combine info in the last two 'cells'
    lRo = 2
    For lRi1 = 2 To UB1 - 1
        lRi2 = lRi1 + 1
        bIdentical = True
        
        For lC = 1 To UB2
            If Not vIn(lRi1, lC) Like vIn(lRi2, lC) Then
                'two lines are not the same, so stop checking
                bIdentical = False
                Exit For
            End If
        Next lC
        If bIdentical Then
            'two lines are identical
            'copy the row to the next row in vOut
            For lC = 1 To UB2
                vOut(lRo, lC) = vIn(lRi1, lC)
            Next lC
            'then combine the last two cells
            vOut(lRo, UB2 + 1) = vIn(lRi1, UB2 + 1) & ", " & vIn(lRi2, UB2 + 1)
            vOut(lRo, UB2 + 2) = vIn(lRi1, UB2 + 2) & ", " & vIn(lRi2, UB2 + 2)
            'increment the line for the output array
            lRo = lRo + 1
            'The 2nd line does not need to be tested again, so increment lRi1 to skip that line in the next loop
            lRi1 = lRi1 + 1
         Else
            'the line below is not identical, so write current line to output array
            For lC = 1 To UB2Last
                vOut(lRo, lC) = vIn(lRi1, lC)
            Next lC
            'increment the line for the output array
            lRo = lRo + 1
         End If
    Next lRi1
    'Check the last line, as in the loop above lRi1 does not reach the lat line!
    If lRi1 = UB1 Then
        'the last line was not duplicate, so copy
        For lC = 1 To UB2Last
            vOut(lRo, lC) = vIn(lRi1, lC)
        Next lC
    End If
    
    'Now write the output array to a new sheet.
    'If you want to overwrite the original table, then set the flag bNewSh to false
    Dim bNewSh As Boolean
    bNewSh = True   'output to new sheet
    
    If bNewSh Then
        ThisWorkbook.Sheets.Add
        ActiveSheet.Name = "CleanedUpTbl"
    End If
    Range("A1").Resize(UB1, UB2Last).Value = vOut
End Sub

 

[sijpie]

To understand arrays, read for instance my Short Guide to Better VBA, see the link in the tagline below