Moving data from a row to column based on dup

I think creating more than four contacts could be possible, but before we move further I just need to confirm your desired outcome.

Could you adjust your sample data to contain two tabs. One with the original data (no extra columns) and then a tab with the final results in the format you desire?

Okay give this a try. Please test on some test data before running macro. Best way, make a copy of the data tab and then run the macro on that sheet.

I have not tested this past the amount of data included, but in awhile I will work on getting the rest done so it is more dynamic. Have to leave right now. Let me know what you think?

This seems to cover it.

Added a timer to the macro and tested with 3600 rows of data and it came out ok.

Note: Remember test out on test data before the real thing.

Okay I think this does it; however, it doesn't quite seem to match your outcome. If this does not work 100% for you then I need some exact details as to what is not transferring correctly.

As I understand it you want to keep unique by company. I count 24 unique companies. On your Outcome workbook you show Douglas Shipman against company Compumail Corp, but on the Test data workbook he is part of the Wethersfield Historical Society Inc company. Which is correct?

Also, when you run this macro it will create a copy of the Raw Data sheet and call it Raw Data Test and that's where the results will be. The Raw Data sheet will stay intact.

Please let me know specifics about where error might arise.

Sub MoveData()
    Dim _
        ws      As Worksheet, _
        Rng     As Range, _
        LR      As Long, _
        LC      As Long, _
        i       As Long, _
        s       As Long, _
        x       As Long, _
        j       As Long: j = 3
        
        Sheets.Add After:=Sheets(Sheets.Count)
        Set ws = ActiveSheet
        ws.Name = "Raw Data Test"
        Sheets("Raw Data").UsedRange.Copy Sheets("Raw Data Test").Range("A1")
        
    With ws
    Application.ScreenUpdating = False
        LR = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set Rng = Range("A2:A" & LR)
        For i = 3 To LR
            If .Cells(i - 1, 1) <> .Cells(i - 2, 1) Then
                If j <> 3 Then j = j + 1
                s = Application.WorksheetFunction.CountIf(Rng, .Cells(i - 1, 1).Text) - 1
                For x = 1 To s
                    LC = .Cells(i - 1, .Columns.Count).End(xlToLeft).Column + 1
                    .Cells(1, LC).Resize(, 5).Value = _
                    Array("First Name" & x + 1, "Last Name" & x + 1, "Title" & x + 1, _
                                    "Contact Number" & x + 1, "Contact Email" & x + 1)
                    .Cells(j, 2).Resize(, 5).Copy .Cells(i - 1, LC)
                    j = j + 1
                Next x
            End If
        Next i
        .Range("A1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
        .UsedRange.Columns.AutoFit
        LC = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
        .Columns("G:S").Cut
        .Columns(LC).Insert Shift:=xlToRight
        Application.Goto [A1]
        Application.ScreenUpdating = True
    End With
End Sub