Merging rows with some duplicate and some unique data - into one row

[kennedy40]

Exporting data from a school database will produce student records on multiple lines, depending on how may parents/guardians a student has in the system. If a student has just one parent, only one row is created. If a student has two (or more) other parents, an additional row is created for each. All of the Student’s information on each row will be identical, but the fields for a parent will be different.

I want to merge rows with multiple parents and have all columns for each parent part of the same row (See attachment).

At most there could be 4 unique parent/guardians for each student.

[pike]

Hi kennedy40
Welcome to excel forum

Why not just use the advance filter unique values?

[jaslake]

Hi kennedy40
This code is in the attached. See if it does as you require.

Option Explicit
Sub combine_guardians()
    Dim LR As Long
    Dim header1 As Variant
    Dim header2 As Variant
    Dim header3 As Variant
    Dim header4 As Variant
    Dim rng As Range
    Dim i As Long
    Dim r As Long

    header1 = Array("relation.1", "First Name.1", "Last Name.1", "E-mail Address.1", "Home Phone.1", "Cellular Phone.1")
    header2 = Array("relation.2", "First Name.2", "Last Name.2", "E-mail Address.2", "Home Phone.2", "Cellular Phone.2")
    header3 = Array("relation.3", "First Name.3", "Last Name.3", "E-mail Address.3", "Home Phone.3", "Cellular Phone.3")
    header4 = Array("relation.4", "First Name.4", "Last Name.4", "E-mail Address.4", "Home Phone.4", "Cellular Phone.4")
    Range("I1").Resize(1, 6).Value = header1
    Range("O1").Resize(1, 6).Value = header2
    Range("U1").Resize(1, 6).Value = header3
    Range("AA1").Resize(1, 6).Value = header4

    Application.ScreenUpdating = False
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Set rng = Range("A2:A" & LR)
    With rng
        r = 6
        For i = LR To 1 Step -1
            If rng(i).Value = rng(i).Offset(-1, 0).Value Then
                rng(i).Offset(0, 8).Resize(1, r).Copy
                rng(i).Offset(-1, 14).Resize(1, r).PasteSpecial
                rng(i).EntireRow.Delete
                r = r + 6
            Else
                r = 6
            End If
        Next i
    End With
    Cells.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

[kennedy40]

John,
This solved my problem completely. Thank you! This will be an immense time saver.

David