VBA - If C2 = x, Move D2 to Next Available

[The Great SrH]

Hi all,

I'm really sorry as I'm struggling to even describe what I'm asking help for here.

I basically have a list of 30,000 rows of data where Column C is the unique number relating to a customer and Column D is a product they hold.

I'm looking for some code to do something like run down the list and if Column C exists, move the information into the next available column after Column D.


For the sake of an example, I'm using Column A as the Unique Number and Column B is the product.


Current List:

Row	Column A	Column B
1	Unique Number	Product
2	12345	Banana
3	12345	Pear
4	7210	Apple
5	12345	Apple
6	1234	Grape
7	7210	Berry
8	7210	Melon
9	12345	Grape
10	12345	Melon
11	7210	Banana
12	5065	Banana
13	5792	Apple
14	5792	Pear
15	8090	Grape

<tbody>
</tbody>

Desired Output:

Row	Column A	Column B	Column C	Column D	Column E	Column F	Column G
1	Unique Number	Product	Product	Product	Product	Product	Product
2	12345	Banana	Pear	Apple	Grape	Melon
3	7210	Apple	Berry	Melon	Banana
4	1234	Grape
5	5065	Banana
6	5792	Apple	Pear
7	8090	Grape

<tbody>
</tbody>

 

[Fluff]

How about

Sub TheGreatSrH()
   Dim Ary As Variant
   Dim r As Long
   
   With Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")
      Ary = .Range("C2", .Range("C" & Rows.Count).End(xlUp).Offset(, 1)).Value2
   End With
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 1)) Then
            .add Ary(r, 1), Ary(r, 2)
         Else
            .Item(Ary(r, 1)) = .Item(Ary(r, 1)) & "|" & Ary(r, 2)
         End If
      Next r
      Sheets("[COLOR=#ff0000]Sheet2[/COLOR]").Range("A2").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .Items))
   End With
   With Sheets("[COLOR=#ff0000]Sheet2[/COLOR]")
      .Range("B2:B" & Rows.Count).TextToColumns .Range("B2"), xlDelimited, xlTextQualifierNone, False, False, False, False, False, True, "|"
   End With
End Sub

Change values in red to suit

 

[The Great SrH]

How about

Sub TheGreatSrH()
   Dim Ary As Variant
   Dim r As Long
   
   With Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")
      Ary = .Range("C2", .Range("C" & Rows.Count).End(xlUp).Offset(, 1)).Value2
   End With
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 1)) Then
            .add Ary(r, 1), Ary(r, 2)
         Else
            .Item(Ary(r, 1)) = .Item(Ary(r, 1)) & "|" & Ary(r, 2)
         End If
      Next r
      Sheets("[COLOR=#ff0000]Sheet2[/COLOR]").Range("A2").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .Items))
   End With
   With Sheets("[COLOR=#ff0000]Sheet2[/COLOR]")
      .Range("B2:B" & Rows.Count).TextToColumns .Range("B2"), xlDelimited, xlTextQualifierNone, False, False, False, False, False, True, "|"
   End With
End Sub

Change values in red to suit

That looks perfect! Thank you so much.

Would it be possible to move the contents of A & B to go next to C in the new Sheet?

Also, to complicate it more - Every product has another cell next to it with a number. So using the desired output above, Column B would still be the Product and then there would be another number next to it (originally in Column E).

 

[Fluff]

For future reference it's best to show exactly what you want rather than an oversimplification.
Can you post 3 or rows of data showing what you have & what you want.

 

[The Great SrH]

Really sorry about that - I only realised after putting your code to test that I actually needed the other data!

Current List:

Row	Column A	Column B	Column C	Column D	Column E
1	Ref	Other	Unique Number	Product	Extra
2	1	A	12345	Banana	2
3	2	B	12345	Pear	1
4	3	C	7210	Apple	1
5	4	D	12345	Apple	2
6	5	E	1234	Grape	2
7	6	F	7210	Berry	1
8	7	G	7210	Melon	2
9	8	H	12345	Grape	2
10	9	I	12345	Melon	1
11	10	J	7210	Banana	1
12	11	Q	5065	Banana	1
13	12	L	5792	Apple	1
14	13	M	5792	Pear	1
15	14	N	8090	Grape	2

<tbody>
</tbody>

Desired Output:

Row	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Ref	Other	Unique Number	Product	Extra	Product	Extra	Product	Extra	Product	Extra	Product	Extra
2	1	A	12345	Banana	2	Pear	1	Apple	2	Grape	2	Melon	1
3	3	C	7210	Apple	1	Berry	1	Melon	2	Banana	1
4	5	E	1234	Grape	2
5	11	Q	5065	Banana	1
6	12	L	5792	Apple	1	Pear	1
7	14	N	8090	Grape	2

<tbody>
</tbody>

 

[Fluff]

Try

Sub TheGreatSrH()
   Dim Ary As Variant, Tmp As Variant, Ky As Variant
   Dim r As Long
   
   With Sheets("Roster")
      Ary = .Range("A2", .Range("C" & Rows.Count).End(xlUp).Offset(, 2)).Value2
   End With
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 3)) Then
            .add Ary(r, 3), Array(Ary(r, 1), Ary(r, 2), Ary(r, 3), Ary(r, 4), Ary(r, 5))
         Else
            Tmp = .Item(Ary(r, 3))
            ReDim Preserve Tmp(0 To UBound(Tmp) + 2)
            Tmp(UBound(Tmp) - 1) = Ary(r, 4)
            Tmp(UBound(Tmp)) = Ary(r, 5)
            .Item(Ary(r, 3)) = Tmp
         End If
      Next r
      For Each Ky In .Keys
         Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, UBound(.Item(Ky)) + 1).Value = .Item(Ky)
      Next Ky
   End With
End Sub

 

[The Great SrH]

Try

Sub TheGreatSrH()
   Dim Ary As Variant, Tmp As Variant, Ky As Variant
   Dim r As Long
   
   With Sheets("Roster")
      Ary = .Range("A2", .Range("C" & Rows.Count).End(xlUp).Offset(, 2)).Value2
   End With
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 3)) Then
            .add Ary(r, 3), Array(Ary(r, 1), Ary(r, 2), Ary(r, 3), Ary(r, 4), Ary(r, 5))
         Else
            Tmp = .Item(Ary(r, 3))
            ReDim Preserve Tmp(0 To UBound(Tmp) + 2)
            Tmp(UBound(Tmp) - 1) = Ary(r, 4)
            Tmp(UBound(Tmp)) = Ary(r, 5)
            .Item(Ary(r, 3)) = Tmp
         End If
      Next r
      For Each Ky In .Keys
         Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, UBound(.Item(Ky)) + 1).Value = .Item(Ky)
      Next Ky
   End With
End Sub

Thanks so much for this - Is it possible for you to explain what you did to change this? I'm waiting for a different report to come in which may need another column moving across - but it's good for me to learn too!

 

[Fluff]

If you would like to comment the code with your understanding of what is happening, I will happily fill in the blanks & correct any misunderstandings if needed.

 

[The Great SrH]

If I'm being honest - I don't know what any of it's doing!

 

[Fluff]

To learn about dictionaries have a look here https://excelmacromastery.com/vba-dictionary/
and for arrays https://excelmacromastery.com/excel-vba-array/

HTH