Consolidate and Concatenate by Creating Columns

I need to consolidate rows into a single row, adding columns as necessary.

Problem:
ID relation name date
68540 Your loved one Agnes A. Schmidt 9-Aug
68540 Your cousin Emry 25-Sep
68540 Your friend Charles 4-Oct

Desired Solution:
ID relation name date relation2 name2 date2 relation3 name3 date3
68540 Your loved one Agnes A. Schmidt 9-Aug Your cousin Emry 25-Sep Your friend Charles 4-Oct

There are over 35,000 rows that I need to consolidate.

I don't know how to create macros from code

It says object required. When I click Debug, it points to Sheet2.Cells(TargetRow, 1_ = Cells(N, 1)

That's what I did, but it gave me the Run-time error '424': Object Required

Please see the attachment for the exact columns I will be working with. I don't know if it makes a difference in the macro, but these are the columns I will be working with.

Hi, to all!

Check this example. I work with your first file. This is the code:

PHP Code: 

Sub ReOrdData()
    Dim a, r, c&, d&, s&, q&, f$, m&, i&, j&
    
    a = Range("A1").CurrentRegion.Value
    s = Range("A" & Rows.Count).End(xlUp).Row
    
    f = "frequency(A2:A" & s & ",A2:A" & s & ")"
    q = Evaluate("sum(n(" & f & ">0))"): m = Evaluate("max(" & f & ")")
    ReDim r(1 To q, 1 To 1 + 3 * m)
    
    For i = 1 + LBound(a) To UBound(a)
        If a(i, 1) <> a(i - 1, 1) Then
            d = 1 + d: c = 1
            r(d, 1) = a(i, 1)
        End If
        For j = 2 To 4
            c = 1 + c: r(d, c) = a(i, j)
        Next j
    Next i
    
    With Range("G1")
        .CurrentRegion.Clear
        .Value = "ID"
        With .Resize(, 4)
            .Value = [{"ID", "relation 1", "name 1", "date 1"}]
            .Offset(, 1).Resize(, 3).AutoFill .Offset(, 1).Resize(, 3 * m)
        End With
        With .Resize(, 1 + 3 * m)
            .Font.Bold = True
            .Interior.Color = rgbLightGray
        End With
        .Offset(1).Resize(q, 1 + 3 * m) = r
        .CurrentRegion.Columns.AutoFit
    End With
    
    Erase a, r
    
End Sub 


For work, click on arrow. Blessings!

@johnmpl thank you! Could you manipulate that code for the second file I uploaded?

@johnmpl the .Interior.Color line messed it up. Once I removed it, I was able to run the macro

Hi, again!

The columns have more data. Upload a file with the resultant data like your new attach. Blessings!

Sorry, I don't understand what you need. I've attached the actual columns excel file.

Originally Posted by andytaylordesigns

Sorry, I don't understand what you need. I've attached the actual columns excel file.

What I wanted to say to you is: What exactly are the columns you need as a result and in what order do you need them according to the new file you uploaded?

Oh I get it. Ok. the repetitive columns like address and salutation, Id and first date column don't need to have extra columns. The only difference between each record is the relative name, relation, and last date column. It's those three last columns that need to be added as extra columns to make one record.

So the column names will be: Date Street 1 Name ID Street 2 city state zip salutation relation relation name dod relation2 relation name2 dod2 relation3 relation name3 dod3 (Etc.)

Hi again, andytaylordesigns!

Check new code:

PHP Code: 

Sub ReOrdData()
    Dim a, r, c&, d&, s&, q&, f$, m&, i&, j&
     
    a = Range("A1").CurrentRegion.Value
    s = Range("D" & Rows.Count).End(xlUp).Row
     
    f = "frequency(D2:D" & s & ",D2:D" & s & ")"
    q = Evaluate("sum(n(" & f & ">0))"): m = Evaluate("max(" & f & ")")
    ReDim r(1 To q, 1 To 7 + 3 * m)
     
    For i = 1 + LBound(a) To UBound(a)
        If a(i, 4) <> a(i - 1, 4) Then
            d = 1 + d: c = 7
            For j = 1 To 7
                r(d, j) = a(i, j)
            Next j
        End If
        For j = 8 To 10
            c = 1 + c: r(d, c) = a(i, j)
        Next j
    Next i
     
    With Range("M1")
        .CurrentRegion.Clear
        Range("A1:G1").Copy Range("M1")
        With .Offset(, 7)
            .Resize(, 3) = [{"relation 1", "relation name 1", "dod 1"}]
            .Resize(, 3).AutoFill .Resize(, 3 * m)
        End With
        With .Resize(, 7 + 3 * m)
            .Font.Bold = True
            .Interior.Color = RGB(180, 180, 180)
        End With
        .Offset(1).Resize(q, 7 + 3 * m) = r
        .CurrentRegion.Columns.AutoFit
    End With
     
    Erase a, r
End Sub 


Check file. Blessings!

@johnmpl Runtime Error 9 Subscript out of range

Originally Posted by andytaylordesigns

@johnmpl Runtime Error 9 Subscript out of range

Which line have errors? I try the code above, just press the arrow, and work all fine...

Originally Posted by johnmpl

Which line have errors? I try the code above, just press the arrow, and work all fine...

It works with those few rows, but when I try the script with all 35,000 rows, it gives me that error.

Originally Posted by andytaylordesigns

It works with those few rows, but when I try the script with all 35,000 rows, it gives me that error.

Can you upload to google drive, or one drive, and share the link here?

Originally Posted by johnmpl

Can you upload to google drive, or one drive, and share the link here?

I'm sorry I can't, it's proprietary information.

Originally Posted by andytaylordesigns

I'm sorry I can't, it's proprietary information.

Change some sensible data, and send it. It's hard to say what's going on without see your file.

Try something: Sort your data by ID column (Column D) and run the code again, because this code works when the data is sorted by ID. Blessings!