VBA Merge Duplicates & Sort Their Corresponding Values

[mtjanousek]

Hello,
I need to create quite a complex macro and so far I was pretty much unsuccessful.

In the first sheet I have those data (the real sheet has about 4000 rows):

P-Number	Note	Code	n/a number	n/a number	Value
00315678001		O9873			23037
00345989001		O9873			14535
00315678001		O4582			14563
00012345002		O9837			89895
00315678001	xx	KP325			0
00345989001		O1246			0
00315678001		AK248			215079
00315678001		KP567			0
00345989001		KA111			9871
00345989001	xx	LI1555			26050
00012345002		VK821			1873
…	…	…	…	…	…

<tbody>
</tbody>

What I need to do is to find the duplicates and merge them in the second sheet while also sum the values for codes starting with a specific letter.

The result should look like this:

P-Number	LI	KA	O
00315678001	0	0	37600
00345989001	26050	9871	14535
00012345002	0	0	91768

<tbody>
</tbody>

As you may see, in the first column I have unique values only (duplicates were merged). In columns B, C, D I have a sum of values for a code starting with a given letter.

In the first sheet, there are codes starting with i.e. KP. I am not interested in those, I am looking for codes matching LI, KA and O only.

Purpose of this macro is to sort out those P-Numbers and show the sum of values for given codes.

So far I tried to merge data using something similar to this: https://www.excelcampus.com/vba/remove-duplicates-list-unique-values/ but that deletes values in rows which I need for sorting. I also tried this approach https://stackoverflow.com/questions...el-and-export-rows-to-another-sheet-using-vba but that's only selecting duplicates, not to mention that I should probably the first sort and merge afterwards.

Would you know how to approach this problem?

 

[Fluff]

How about

Sub CombineDupes()
   Dim Cl As Range
   Dim tmp As Double
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then
            .add Cl.Value, Array(0, 0, 0)
            If Left(Cl.Offset(, 2), 2) = "LI" Then
               .Item(Cl.Value) = Array(Cl.Offset(, 5).Value, 0, 0)
            ElseIf Left(Cl.Offset(, 2), 2) = "KA" Then
               .Item(Cl.Value) = Array(0, Cl.Offset(, 5).Value, 0)
            ElseIf Left(Cl.Offset(, 2), 1) = "O" Then
               .Item(Cl.Value) = Array(0, 0, Cl.Offset(, 5).Value)
            End If
         Else
            If Left(Cl.Offset(, 2), 2) = "LI" Then
               tmp = .Item(Cl.Value)(0) + Cl.Offset(, 5).Value
               .Item(Cl.Value) = Array(tmp, .Item(Cl.Value)(1), .Item(Cl.Value)(2))
            ElseIf Left(Cl.Offset(, 2), 2) = "KA" Then
               tmp = .Item(Cl.Value)(1) + Cl.Offset(, 5).Value
               .Item(Cl.Value) = Array(.Item(Cl.Value)(0), tmp, .Item(Cl.Value)(2))
            ElseIf Left(Cl.Offset(, 2), 1) = "O" Then
               tmp = .Item(Cl.Value)(2) + Cl.Offset(, 5).Value
               .Item(Cl.Value) = Array(.Item(Cl.Value)(0), .Item(Cl.Value)(1), tmp)
            End If
         End If
      Next Cl
      Debug.Print .Count
      Sheets("Sheet2").Range("A2").Resize(.Count).Value = Application.Transpose(.keys)
      Sheets("Sheet2").Range("b2").Resize(.Count, 3).Value = Application.Index(.items, 0, 0)
   End With
End Sub

 

[mtjanousek]

Thanks so much!
Is there a way how to insert values for P-Number column unformatted? Because otherwise those zeros in front of the number will get lost.

 

[Fluff]

Try

Sub CombineDupes()
   Dim cl As Range
   Dim tmp As Double
   
   With CreateObject("scripting.dictionary")
      For Each cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
         If Not .exists(cl.Value) Then
            .add cl.Value, Array(0, 0, 0)
            If Left(cl.Offset(, 2), 2) = "LI" Then
               .Item(cl.Value) = Array(cl.Offset(, 5).Value, 0, 0)
            ElseIf Left(cl.Offset(, 2), 2) = "KA" Then
               .Item(cl.Value) = Array(0, cl.Offset(, 5).Value, 0)
            ElseIf Left(cl.Offset(, 2), 1) = "O" Then
               .Item(cl.Value) = Array(0, 0, cl.Offset(, 5).Value)
            End If
         Else
            If Left(cl.Offset(, 2), 2) = "LI" Then
               tmp = .Item(cl.Value)(0) + cl.Offset(, 5).Value
               .Item(cl.Value) = Array(tmp, .Item(cl.Value)(1), .Item(cl.Value)(2))
            ElseIf Left(cl.Offset(, 2), 2) = "KA" Then
               tmp = .Item(cl.Value)(1) + cl.Offset(, 5).Value
               .Item(cl.Value) = Array(.Item(cl.Value)(0), tmp, .Item(cl.Value)(2))
            ElseIf Left(cl.Offset(, 2), 1) = "O" Then
               tmp = .Item(cl.Value)(2) + cl.Offset(, 5).Value
               .Item(cl.Value) = Array(.Item(cl.Value)(0), .Item(cl.Value)(1), tmp)
            End If
         End If
      Next cl
      Sheets("Sheet2").Range("A:A").NumberFormat = "@"
      Sheets("Sheet2").Range("A2").Resize(.Count).Value = Application.Transpose(.keys)
      Sheets("Sheet2").Range("b2").Resize(.Count, 3).Value = Application.Index(.items, 0, 0)
   End With
End Sub

 

[mtjanousek]

Thank you, that actually worked perfectly in my example. However, I am having an issue to apply it to the real file where is multiple numbers of sheets. I specified a worksheet for range, but it didn't work (Runtime error 9, subscript out of range). I tried to understand to code since I have never used dictionary or arrays, but I apparently missed something.

'   Create Sub
Sub CombineDupes()
'   Declare a cell as a "Range" and temp as "real numbers"
   Dim ws As Worksheet
   Set ws = Worksheets("List1")
   Dim cl As Range
   Dim tmp As Double
   
'   Create a dictionary
   With CreateObject("scripting.dictionary")
      For Each cl In ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp))   ' Set a "Range" in column A from A2 till the end
         If Not .exists(cl.Value) Then                                      ' ?If in a cell there is no value, then add value to the cell?
            .Add cl.Value, Array(0, 0, 0)                                   ' Create an array with (i, j, k)
            If Left(cl.Offset(, 2), 2) = "LI" Then                          ' If there is "LI" (column C, 2 letters)
               .Item(cl.Value) = Array(cl.Offset(, 12).Value, 0, 0)         ' Then add value to "i"
            ElseIf Left(cl.Offset(, 2), 2) = "KA" Then                      ' If there is "KA" (column C, 2 letters)
               .Item(cl.Value) = Array(0, cl.Offset(, 12).Value, 0)         ' Then add value to "j"
            ElseIf Left(cl.Offset(, 2), 1) = "O" Then                       ' If there is "O" (column C, 1 letter)
               .Item(cl.Value) = Array(0, 0, cl.Offset(, 12).Value)         ' Then add value to "k"
            End If
'   Sum of LIs, KAs, Os
        Else
            If Left(cl.Offset(, 2), 2) = "LI" Then                                      ' Set the term (column C, 2 letters)
               tmp = .Item(cl.Value)(0) + cl.Offset(, 12).Value                         ' SUM
               .Item(cl.Value) = Array(tmp, .Item(cl.Value)(1), .Item(cl.Value)(2))     ' Write to "i"
            ElseIf Left(cl.Offset(, 2), 2) = "KA" Then                                  ' Set the term (column C, 2 letters)
               tmp = .Item(cl.Value)(1) + cl.Offset(, 12).Value                         ' SUM
               .Item(cl.Value) = Array(.Item(cl.Value)(0), tmp, .Item(cl.Value)(2))     ' Write to "j"
            ElseIf Left(cl.Offset(, 2), 1) = "O" Then                                   ' Set the term (column C, 1 letter)
               tmp = .Item(cl.Value)(2) + cl.Offset(, 12).Value                         ' SUM
               .Item(cl.Value) = Array(.Item(cl.Value)(0), .Item(cl.Value)(1), tmp)     ' Write to "k"
            End If
         End If
'   Next cell
      Next cl
'   Set a "Range" for results
      Sheets("Sheet2").Range("A:A").NumberFormat = "@"                                          ' Unformated number in column A
      Sheets("Sheet2").Range("A2").Resize(.Count).Value = Application.Transpose(.keys)          ' Write into A2
      Sheets("Sheet2").Range("B2").Resize(.Count, 3).Value = Application.Index(.items, 0, 0)    ' Write starting with B2 and in three clumns (i.e. C and D)
   End With
End Sub

' Note: Array starts with 0, aka A=0, C=2, M=12...

 

[Fluff]

Which line gives the error?

I have amended your comments on these 2 lines

    If Not .exists(cl.Value) Then                                      ' Checks if the cell value exists in the dictionary
            .add cl.Value, Array(0, 0, 0)                                   ' if it's not in the dictionary add the cell value  & Create an array with (i, j, k)

 

[mtjanousek]

Thanks for comments. That is really helpful.

I just found the reason for this problem. Apparently, the sheet is formatted as a Table, hence the error about the range. I tried to convert it back to the normal format manually and afterwards run the macro before trying it with a script, but it didn't help. Also, I need to keep this sheet intact since it is automatically updated and filled by new data coming from the server.

Is there any nice and easy solution? Otherwise, I will probably let the macro to create a new sheet and copy paste the data which will be used afterwards to do the calculation. But it sounds a little bit clumsy.

 

[Fluff]

Which sheet contains the table?
Also the fact you have a table shouldn't give the error you described.

 

[mtjanousek]

You were right. The issue was in the source sheet which was using diacritics. Now everything runs smoothly. Once more, hanks a lot for your help!

 

[Fluff]

Glad it's working & thanks for the feedback