Move matching cell and their adjacent cells in a column to a row

[rachel4595]

Hello all - thank you in advance for any help.

I am trying to get an email list together for students in my school. Right now, I have a list of each student in the school and their parent's email. We have some student's whose parents have given separate emails for mom and dad. So the list looks like this:

Jones, Ann ID#1 momjones@gmail.com
Smith, Joe ID#2 momsmith@gmail.com
Smith, Joe ID#3 dadsmith@gmail.com
Smith, Jane ID#2 momsmith@gmail.com
Smith, Jane ID#3 dadsmith@gmail.com
Wilson, Jake ID#4 momwilson@gmail.com
Zim, Rachel ID#5 momzim@gmail.com
Zim, Zack ID#6 momzim@gmail.com
Zim, Zed ID#7 momzim@gmail.com

I need to create a spreadsheet that will be used in Mail Chimp to email each parent their child's specific ID# - it is actually a unique website address each student has for certain school information. I only want one email per parent so I need to combine all of the same kids in a family to the same row. so it is sorted like this:

momjones@gmail.com Jones, Ann ID#1
momsmith@gmail.com Smith, Joe ID#2 Smith, Jane ID#3
dadsmith@gmail.com Smith, Joe ID#2 Smith, Jane ID#3
momwilsoon@gmail.com Wilson, Jake ID#4
momzim@gmail.com Zim, Rachel ID#5 Zim, Zack ID#6 Zim, Zed ID#7

Any thoughts on how to do this? I need each parent email on a separate line for the email list. There are no more than 5 students in the same family in the school - so that's the most that would be in a row.
Thanks for your help!

 

[rachel4595]

?

 

[lrobbo314]

The easiest way I can think of is to put it in a pivot table. Have the parents' email as the value for rows and the student name as the value for columns.
If you have Excel 2016 you can add the table to the data model and manipulate the data to look exactly like your example.

 

[lrobbo314]

Here's a VBA solution as well. It will give you the results like in your OP.

Sub unwind()
On Error GoTo errH
Dim col     As New Collection
Dim r       As Range
Dim ws      As Worksheet
Dim unw     As Worksheet
Dim ar()
Set ws = ActiveSheet
Set r = Selection
For i = 2 To r.Rows.Count
    col.Add Cells(i, 3).Value, Cells(i, 3).Value
Next i
Sheets.Add after:=ActiveSheet
ActiveSheet.Name = "Unwound"
Set unw = Sheets("Unwound")
For i = 1 To col.Count
    unw.Cells(i, 1).Value = col(i)
Next i
For i = 1 To col.Count
    For j = 2 To r.Rows.Count
        If ws.Cells(j, 3).Value = col(i) Then
            unw.Range(Cells(i, Columns.Count).Address).End(xlToLeft).Offset(, 1).Value = ws.Cells(j, 2).Value
            unw.Range(Cells(i, Columns.Count).Address).End(xlToLeft).Offset(, 1).Value = ws.Cells(j, 1).Value
        End If
    Next j
Next i
Exit Sub
errH:
If Err.Number = 457 Then
    Resume Next
Else
    MsgBox "Error #" & Err.Number & vbCrLf & Err.Description, vbOKOnly + vbCritical, "Error"
    Resume Next
End If
End Sub

Just select all the information, the student's names, IDs, and parent emails, then run the code.

To run the code, Hit Alt + F8. Then select the module and click "Run".