Combining Data from Multiple Rows

[Dratchsky]

Good Morning,

I am looking for a solution to quickly help fill rows based on their shared Value in Column D

I have several group id (Column D) that I need to have go from this

Book7
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X
1	id_num	last_name	first_name	GroupID	mobile_phone	email_address	Room 1 ID	Room 1 L	Room 1 F	GroupID	Room 1 Phone	Room 1 Email	Room 2 ID Number	Room 2 L	Room 2 F	GroupID	Room 2 Phone	Room 2 Email	Room 3 ID	Room 3 L	Room 3 F	GroupID	Room 3 Phone	Room 3 Email
2	519254	Last1	First1	GH106	(1) 234-5678	Last1.First1@test.com
3	503820	Last2	First2	GH106	(1) 234-5678	Last2.First2@test.com
4	503854	Last3	First3	GH106	(1) 234-5678	Last3.First3@test.com
5	510131	Last4	First4	GH108	(1) 234-5678	Last4.First4@test.com
6	481242	Last5	First5	GH118	(1) 234-5678	Last5.First5@test.com
7	474673	Last6	First6	GH118	(1) 234-5678	Last6.First6@test.com
8	506636	Last7	First7	GH118	(1) 234-5678	Last7.First7@test.com
9	507597	Last8	First8	GH118	(1) 234-5678	Last8.First8@test.com
Sheet1

To This:

Book6
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X
1	id_num	last_name	first_name	GroupID	mobile_phone	email_address	Room 1 ID	Room 1 L	Room 1 F	GroupID	Room 1 Phone	Room 1 Email	Room 2 ID Number	Room 2 L	Room 2 F	GroupID	Room 2 Phone	Room 2 Email	Room 3 ID	Room 3 L	Room 3 F	GroupID	Room 3 Phone	Room 3 Email
2	519254	Last1	First1	GH106	(1) 234-5678	Last1.First1@test.com	503820	Last2	First2	GH106	(1) 234-5678	Last2.First2@test.com	503854	Last3	First3	GH106	(1) 234-5678	Last3.First3@test.com
3	503820	Last2	First2	GH106	(1) 234-5678	Last2.First2@test.com	519254	Last1	First1	GH106	(1) 234-5678	Last1.First1@test.com	503854	Last3	First3	GH106	(1) 234-5678	Last3.First3@test.com
4	503854	Last3	First3	GH106	(1) 234-5678	Last3.First3@test.com	519254	Last1	First1	GH106	(1) 234-5678	Last1.First1@test.com	503820	Last2	First2	GH106	(1) 234-5678	Last2.First2@test.com
5	510131	Last4	First4	GH108	(1) 234-5678	Last4.First4@test.com
6	481242	Last5	First5	GH118	(1) 234-5678	Last5.First5@test.com	474673	Last6	First6	GH118	(1) 234-5678	Last6.First6@test.com	506636	Last7	First7	GH118	(1) 234-5678	Last7.First7@test.com	507597	Last8	First8	GH118	(1) 234-5678	Last8.First8@test.com
7	474673	Last6	First6	GH118	(1) 234-5678	Last6.First6@test.com	481242	Last5	First5	GH118	(1) 234-5678	Last5.First5@test.com	506636	Last7	First7	GH118	(1) 234-5678	Last7.First7@test.com	507597	Last8	First8	GH118	(1) 234-5678	Last8.First8@test.com
8	506636	Last7	First7	GH118	(1) 234-5678	Last7.First7@test.com	481242	Last5	First5	GH118	(1) 234-5678	Last5.First5@test.com	474673	Last6	First6	GH118	(1) 234-5678	Last6.First6@test.com	507597	Last8	First8	GH118	(1) 234-5678	Last8.First8@test.com
9	507597	Last8	First8	GH118	(1) 234-5678	Last8.First8@test.com	481242	Last5	First5	GH118	(1) 234-5678	Last5.First5@test.com	474673	Last6	First6	GH118	(1) 234-5678	Last6.First6@test.com	506636	Last7	First7	GH118	(1) 234-5678	Last7.First7@test.com
Sheet1

 

[DanteAmor]

Try this:

Sub Combining_Data()
  Dim a As Variant, b As Variant
  Dim dic As Object
  Dim i As Long, j As Long, k As Long, m As Long, n As Long
  Dim rws As Variant, ky As Variant
  
  a = Range("A2", Range("F" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a), 1 To UBound(a) * UBound(a))
  Set dic = CreateObject("Scripting.Dictionary")
  
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 4)) Then
      dic(a(i, 4)) = i
    Else
      dic(a(i, 4)) = dic(a(i, 4)) & "|" & i
    End If
  Next
  
  For Each ky In dic.keys
    rws = Split(dic(ky), "|")
    For i = 0 To UBound(rws)
      n = 1
      m = rws(i)
      For j = 0 To UBound(rws)
        If j <> i Then
          For k = 1 To 6
            b(m, n) = a(rws(j), k)
            n = n + 1
          Next k
        End If
      Next j
    Next i
  Next
  Range("G2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

 

[DanteAmor]

Use this version with the code a bit simplified.

Sub Combining_Data()
  Dim dic As Object
  Dim i As Long, j As Long, k As Long, n As Long
  Dim a As Variant, b As Variant, rws As Variant, it As Variant
  
  a = Range("A2", Range("F" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a), 1 To UBound(a) * UBound(a))
  Set dic = CreateObject("Scripting.Dictionary")
  
  For i = 1 To UBound(a)
    dic(a(i, 4)) = dic(a(i, 4)) & "|" & i
  Next
  
  For Each it In dic.items
    rws = Split(it, "|")
    For i = 1 To UBound(rws)
      n = 1
      For j = 1 To UBound(rws)
        If j <> i Then
          For k = 1 To 6
            b(rws(i), n) = a(rws(j), k)
            n = n + 1
          Next k
        End If
      Next j
    Next i
  Next it
  Range("G2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

 

[Dratchsky]

Use this version with the code a bit simplified.

Sub Combining_Data()
  Dim dic As Object
  Dim i As Long, j As Long, k As Long, n As Long
  Dim a As Variant, b As Variant, rws As Variant, it As Variant
 
  a = Range("A2", Range("F" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a), 1 To UBound(a) * UBound(a))
  Set dic = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(a)
    dic(a(i, 4)) = dic(a(i, 4)) & "|" & i
  Next
 
  For Each it In dic.items
    rws = Split(it, "|")
    For i = 1 To UBound(rws)
      n = 1
      For j = 1 To UBound(rws)
        If j <> i Then
          For k = 1 To 6
            b(rws(i), n) = a(rws(j), k)
            n = n + 1
          Next k
        End If
      Next j
    Next i
  Next it
  Range("G2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

Good Morning unfortunately this hasn't worked I am receiving a run time error.

 

[DanteAmor]

It would help if you put the full error message.
Press the debug button and a line of the macro is highlighted in yellow, put here what that line is.
Also put here the data you are testing with. Since with the sample data you put it works fine.

 

[Dratchsky]

It would help if you put the full error message.
Press the debug button and a line of the macro is highlighted in yellow, put here what that line is.
Also put here the data you are testing with. Since with the sample data you put it works fine.

 

[DanteAmor]

Press the OK button and check if any line in the macro is highlighted.
Did you copy the whole macro?
Did you modify something in the macro?

 

[Dratchsky]

Press the OK button and check if any line in the macro is highlighted.
Did you copy the whole macro?
Did you modify something in the macro?

I did not modify anything and unfortunately nothing is highlighted after hitting ok

 

[DanteAmor]

You could upload a copy of your file with the macro to a free site such google drive. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[Dratchsky]

You could upload a copy of your file with the macro to a free site such google drive. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

Copy of Template 2.xlsm

drive.google.com