VBA Dictionary to merge rows

Guinaba · Jul 13, 2023

Hi guys,

Wondering if there is a way to combine rows like the example below, my range has 10 columns and whenever there is the same record in a different row, after running the code the new format is the bottom part:

The code still not correct, but I appreciate any suggestion.

VBA Code:

Sub DataDic()
  Dim dic As Object
  Dim a As Variant
  Dim c As Range
  Dim i As Long

  Set dic = CreateObject("Scripting.Dictionary")

  With Sheets("Export")
    ReDim a(1 To .Range("A" & Rows.Count).End(xlUp).Row, 1 To 10)
    For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
      If Not dic.exists(c.Value) Then
        i = i + 1
        dic(c.Value) = i
        a(i, 1) = c.Value
        a(i, 2) = c.Offset(, 1).Value
        a(i, 3) = c.Offset(, 2).Value
        a(i, 4) = c.Offset(, 3).Value
        a(i, 5) = c.Offset(, 4).Value
        a(i, 6) = c.Offset(, 5).Value
        a(i, 7) = c.Offset(, 6).Value
        a(i, 8) = c.Offset(, 7).Value
        a(i, 9) = c.Offset(, 8).Value
        a(i, 10) = c.Offset(, 9).Value
      Else
        i = dic(c.Value)
        a(i, 10) = a(i, 10) & Chr(10) & c.Offset(, 5).Value
      End If
    Next
    .Range("M2").Resize(UBound(a), 3).Value = a
  End With
  Set dic = Nothing
End Sub

DanteAmor · Jul 13, 2023

Try:

VBA Code:

Sub DataDic()
  Dim sh1 As Worksheet
  Dim dic As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, n As Long

  Set sh1 = Sheets("Export")
  Set dic = CreateObject("Scripting.Dictionary")

  a = sh1.Range("A2:J" & sh1.Range("A" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
        
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then dic(a(i, 1)) = dic.Count + 1
    n = dic(a(i, 1))
    For j = 1 To UBound(a, 2)
      If b(n, j) = "" Then b(n, j) = a(i, j)
      If b(n, j) <> a(i, j) Then b(n, j) = b(n, j) & ", " & Chr(10) & a(i, j)
    Next
  Next
  sh1.Range("M2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------

Guinaba · Jul 14, 2023

DanteAmor said:

Try:

VBA Code:

Sub DataDic()
  Dim sh1 As Worksheet
  Dim dic As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, n As Long

  Set sh1 = Sheets("Export")
  Set dic = CreateObject("Scripting.Dictionary")

  a = sh1.Range("A2:J" & sh1.Range("A" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
      
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then dic(a(i, 1)) = dic.Count + 1
    n = dic(a(i, 1))
    For j = 1 To UBound(a, 2)
      If b(n, j) = "" Then b(n, j) = a(i, j)
      If b(n, j) <> a(i, j) Then b(n, j) = b(n, j) & ", " & Chr(10) & a(i, j)
    Next
  Next
  sh1.Range("M2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------

Hey @DanteAmor,

Thank you for your prompt help, but the code still not generating the correct format, here is the source data that I am using:

Input:

Material Number	Location ID	Expiry Date	EXTN Flag	Tip Date	Stock Status	Batch ID	Sum of QTY (ZPU)	EXTN Flag	EXTN Days
1253031	1024	7/02/2024	N	30/08/2023		0000145242	2970	N	0
1253031	1024	7/02/2024	N	30/08/2023		0000145259	3879	N	0
1253031	1026	6/02/2024	N	29/08/2023		0000145072	3780	N	0
1253031	1026	6/02/2024	N	29/08/2023		0000145110	2249	N	0
1253031	1026	6/02/2024	N	29/08/2023		0000145174	1620	N	0
1253031	1026	6/02/2024	N	29/08/2023		0000145230	810	N	0
1253031	1026	13/02/2024	N	5/09/2023		0000145889	3330	N	0
1253031	1026	13/02/2024	N	5/09/2023		0000145959	3240	N	0
1253031	1026	13/02/2024	N	5/09/2023		0000145979	720	N	0
1253031	1026	13/02/2024	Y	5/09/2023		0000145994	1800	N	0
1253031	1026	13/02/2024	N	5/09/2023	InTransit	0000145857_IT	360	N	0
1253031	1026	13/02/2024	N	5/09/2023	InTransit	0000145889_IT	540	N	0
1253031	1026	13/02/2024	N	5/09/2023	InTransit	0000145959_IT	720	N	0
1253031	1026	13/02/2024	N	5/09/2023	InTransit	0000145994_IT	540	N	0
1253031	1026	23/02/2024	N	15/09/2023		0000146925	1890	N	0
1253031	1026	28/02/2024	N	20/09/2023	InTransit	0000147348_IT	1890	N	0
1253031	1026	28/02/2024	N	20/09/2023	InTransit	0000147379_IT	90	N	0
1253031	1026	28/02/2024	N	20/09/2023	InTransit	0000147450_IT	3060	N	0
1253031	1030	27/02/2024	N	19/09/2023		0000147293	13	N	0
1253031	1030	28/02/2024	N	20/09/2023		0000147379	90	N	0

Output:

Material Number	Location ID	Expiry Date	EXTN Flag	Tip Date	Stock Status	Batch ID	Sum of QTY (ZPU)	EXTN Flag	EXTN Days
1253031	1024	7/02/2024	N	30/08/2023		145242,145259	2970,3879	N	0
1253031	1026	6/02/2024	N	29/08/2023		145072,145110,145174,145230,145889,145959,145979	3780,2249,1620,810,3330,3240,720	N	0
1253031	1026	13/02/2024	Y	5/09/2023		145994	1800	N	0
1253031	1026	13/02/2024	N	5/09/2023	InTransit	0000145857_IT,0000145889_IT,0000145959_IT,0000145994_IT	360,540,720,540	N	0
1253031	1026	23/02/2024	N	15/09/2023		146925	1890	N	0
1253031	1026	28/02/2024	N	20/09/2023	InTransit	0000147348_IT,0000147379_IT,0000147450_IT	1890,90,3060	N	0
1253031	1030	27/02/2024	N	19/09/2023		147293	13	N	0
1253031	1030	28/02/2024	N	20/09/2023		147379	90	N	0

DanteAmor · Jul 14, 2023

Guinaba said:
but the code still not generating the correct format

My code works as seen in your macro:

Guinaba said:
For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
If Not dic.exists(c.Value) Then

That means the grouper is column A and that's just what my macro does.
-----------------------

Your example in the original post with only 2 records is not very representative. You must clearly explain which fields you need to carry out the grouping, they are your data and I do not know what the final objective is.
So explain what those columns are to group.

Your example from post #3 is not very clear either.
You are grouping the following numbers highlighted in yellow in a row where the date does not correspond, so you must explain what the grouping rules are for each of your records.

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------

Guinaba · Jul 14, 2023

Hey @DanteAmor,

Sorry, the logic was confusing for me, hopefully I am ansering your questions now.

I believe if you index columns (1,2,3,4,5,6,7,8), you will hit the nail on the head! Instead of only (A) , like in your code,

For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
If Not dic.exists(c.Value) Then

Columns (1,2,3,4,5,6,7,8) should be indexed.


INPUT
1	2	3	4	5	6	7	8
Material Number	Material Description	Location ID	Expiry Date	EXTN Flag	EXTN Days	Tip Date	Stock Status	QTY (ZPU)	Batch ID
1253031	XXXX Gold 30x375ml CAN DD 21	1026	28/02/2024	N	0	20/09/2023	InTransit	3060	0000147450_IT
1253031	XXXX Gold 30x375ml CAN DD 21	1026	28/02/2024	N	0	20/09/2023	InTransit	90	0000147379_IT
1253031	XXXX Gold 30x375ml CAN DD 21	1026	28/02/2024	N	0	20/09/2023	InTransit	1890	0000147348_IT
1253031	XXXX Gold 30x375ml CAN DD 21	1026	23/02/2024	N	0	15/09/2023		1890	0000146925
1253031	XXXX Gold 30x375ml CAN DD 21	1026	13/02/2024	N	0	05/09/2023	InTransit	540	0000145994_IT
1253031	XXXX Gold 30x375ml CAN DD 21	1026	13/02/2024	N	0	05/09/2023		1800	0000145994
1253031	XXXX Gold 30x375ml CAN DD 21	1026	13/02/2024	N	0	05/09/2023		720	0000145979
1253031	XXXX Gold 30x375ml CAN DD 21	1026	13/02/2024	N	0	05/09/2023	InTransit	720	0000145959_IT
1253031	XXXX Gold 30x375ml CAN DD 21	1026	13/02/2024	N	0	05/09/2023		3240	0000145959
1253031	XXXX Gold 30x375ml CAN DD 21	1026	13/02/2024	N	0	05/09/2023	InTransit	540	0000145889_IT
1253031	XXXX Gold 30x375ml CAN DD 21	1026	13/02/2024	N	0	05/09/2023		3330	0000145889
1253031	XXXX Gold 30x375ml CAN DD 21	1026	13/02/2024	N	0	05/09/2023	InTransit	360	0000145857_IT
1253031	XXXX Gold 30x375ml CAN DD 21	1024	07/02/2024	N	0	30/08/2023		3879	0000145259
1253031	XXXX Gold 30x375ml CAN DD 21	1024	07/02/2024	N	0	30/08/2023		2970	0000145242





OUPUT
1	2	3	4	5	6	7	8
Material Number	Material Description	Location ID	Expiry Date			Tip Date	Stock Status	QTY (ZPU)	Batch ID
1253031	XXXX Gold 30x375ml CAN DD 21	1026	28/02/2024	N	0	20/09/2023	InTransit	3060,90,1890	0000147450_IT,0000147379_IT,0000147348_IT
1253031	XXXX Gold 30x375ml CAN DD 21	1026	23/02/2024	N	0	15/09/2023		1890	0000146925
1253031	XXXX Gold 30x375ml CAN DD 21	1026	13/02/2024	N	0	5/09/2023	,InTransit, ,InTransit, ,InTransit, ,InTransit	540,1800,720,720,3240,540,3330,360	0000145994_IT,0000145994,0000145979,0000145959_IT,0000145959,0000145889_IT,0000145889,0000145857_IT
1253031	XXXX Gold 30x375ml CAN DD 21	1024	7/02/2024	N	0	30/08/2023		3879,2970	0000145259,0000145242

DanteAmor · Jul 14, 2023

Again you changed the examples, you are not consistent in the examples.
Your example has errors.

The QTYs highlighted in yellow must be in another record since the Stock status column is empty, so they must not be on the same "Intransit" line

I give you the macro with the 8 column key, but the macro does not return the results as you are putting it.
From now on try to be consistent, clear and truthful with the examples.

VBA Code:

Sub DataDic()
  Dim sh1 As Worksheet
  Dim dic As Object
  Dim a As Variant, b As Variant, ky As Variant
  Dim i As Long, j As Long, n As Long

  Set sh1 = Sheets("Export")
  Set dic = CreateObject("Scripting.Dictionary")

  a = sh1.Range("A2:J" & sh1.Range("A" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
  sh1.Range("M2:V" & Rows.Count).ClearContents
        
  For i = 1 To UBound(a)
    ky = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & _
         a(i, 5) & "|" & a(i, 6) & "|" & a(i, 7) & "|" & a(i, 8)
    If Not dic.exists(ky) Then dic(ky) = dic.Count + 1
    n = dic(ky)
    For j = 1 To UBound(a, 2)
      If b(n, j) = "" Then b(n, j) = a(i, j)
      If b(n, j) <> a(i, j) Then b(n, j) = b(n, j) & ", " & a(i, j)
    Next
  Next
  sh1.Range("M2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

Although I would like to continue offering my help, I will no longer do so because the examples are not consistent with what is described and that caused the macro not to work, but it is not a problem with the macro, it is a problem with the definition of the poster's data .

Guinaba · Jul 16, 2023

DanteAmor said:
Again you changed the examples, you are not consistent in the examples.
Your example has errors.

The QTYs highlighted in yellow must be in another record since the Stock status column is empty, so they must not be on the same "Intransit" line

View attachment 95302

I give you the macro with the 8 column key, but the macro does not return the results as you are putting it.
From now on try to be consistent, clear and truthful with the examples.

VBA Code:

Sub DataDic() Dim sh1 As Worksheet Dim dic As Object Dim a As Variant, b As Variant, ky As Variant Dim i As Long, j As Long, n As Long Set sh1 = Sheets("Export") Set dic = CreateObject("Scripting.Dictionary") a = sh1.Range("A2:J" & sh1.Range("A" & Rows.Count).End(3).Row).Value ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) sh1.Range("M2:V" & Rows.Count).ClearContents For i = 1 To UBound(a) ky = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & _ a(i, 5) & "|" & a(i, 6) & "|" & a(i, 7) & "|" & a(i, 8) If Not dic.exists(ky) Then dic(ky) = dic.Count + 1 n = dic(ky) For j = 1 To UBound(a, 2) If b(n, j) = "" Then b(n, j) = a(i, j) If b(n, j) <> a(i, j) Then b(n, j) = b(n, j) & ", " & a(i, j) Next Next sh1.Range("M2").Resize(UBound(b, 1), UBound(b, 2)).Value = b End Sub

Although I would like to continue offering my help, I will no longer do so because the examples are not consistent with what is described and that caused the macro not to work, but it is not a problem with the macro, it is a problem with the definition of the poster's data .

Thanks @DanteAmor, the numbers messed up when copying and pasting into the website, but the logic I told you was corrrect now. Just looking at the picture I sent you having different collors per group, I believe you would be able to understand the logic. Anyway, thanks for your help. The sub is working now as expect.

DanteAmor · Jul 16, 2023

Please mark the post that has the solution, unless your own post contains the solution. Thank you
Dante Amor

DanteAmor · Jul 16, 2023

Guinaba said:
Columns (1,2,3,4,5,6,7,8) should be indexed.

If the result is not what you are looking for, you can remove column 8 in this line of the macro:

VBA Code:

ky = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & _
         a(i, 5) & "|" & a(i, 6) & "|" & a(i, 7) & "|" & a(i, 8)

For example:

VBA Code:

ky = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & _
         a(i, 5) & "|" & a(i, 6) & "|" & a(i, 7)

If the rules change later, you can play with those columns to determine which columns will be the index.

Guinaba · Jul 16, 2023

DanteAmor said:
If the result is not what you are looking for, you can remove column 8 in this line of the macro:

VBA Code:

ky = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & _ a(i, 5) & "|" & a(i, 6) & "|" & a(i, 7) & "|" & a(i, 8)

For example:

VBA Code:

ky = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & _ a(i, 5) & "|" & a(i, 6) & "|" & a(i, 7)

If the rules change later, you can play with those columns to determine which columns will be the index.

Awesome!! Thanks @DanteAmor!

VBA Dictionary to merge rows

Guinaba

Board Regular

Excel Facts

DanteAmor

Well-known Member

Guinaba

Board Regular

DanteAmor

Well-known Member

Guinaba

Board Regular

Attachments

DanteAmor

Well-known Member

Guinaba

Board Regular

DanteAmor

Well-known Member

DanteAmor

Well-known Member

Guinaba

Board Regular

Similar threads

Forum statistics

Share this page

VBA Dictionary to merge rows

Board Regular

Excel Facts

Well-known Member

Board Regular

Well-known Member

Board Regular

Attachments

Well-known Member

Board Regular

Well-known Member

Well-known Member

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock