help moving data

[sjgidman1982]

in the image below there is a table i have downloaded, the information is spread accross multiple rows and i want it all to be on the same row as i have done for the first entry then i need to delete the duplicate name values in the first column

any ideas?

thanks in advance

Untitled.png

[protonLeah]

(How to) Upload a Workbook directly to the Forum
(please do not post pictures or links to worksheets)

• Click Advanced next to Quick Post button at the bottom right of the editor box.
• Scroll down until you see "Manage Attachments",
• Click the "Choose" button at the upper left (upload from your computer).
• Select your file, click "open", click "upload"
• Once the upload is completed the file name will appear below the input boxes in this window.
• Close the Attachment Manager window.
• Click "Submit Reply"

Note: Please do not attach password protected workbooks/worksheets
Ensure to disable any Workbook Open/Autorun macros before attaching!

[sjgidman1982]

workbook attached

[protonLeah]

Option Explicit
Sub MergeRows()
    Dim LastRec     As Long, _
        TitleCount  As Long, _
        CurrentRec  As Long, _
        Ndx         As Long, _
        DestRow     As Long, _
        FieldPtr       As Long, _
        TitleList   As Range, _
        TestTitle   As String
        
    Dim MergeRec(1 To 1, 1 To 12) As Variant
    
    LastRec = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    Set TitleList = Sheets("Sheet1").Range("A2:A" & LastRec)
    
    For CurrentRec = 2 To LastRec
        TestTitle = Sheets("Sheet1").Cells(CurrentRec, 1).Value
        MergeRec(1, 1) = TestTitle
        
        'count the occurances of each title in the list
        TitleCount = Application.WorksheetFunction.CountIf(TitleList, TestTitle)
        
        FieldPtr = 1
        For Ndx = CurrentRec To CurrentRec + TitleCount - 1
            
            'check each field of each record, if not blank copy to mergerec
            FieldPtr = FieldPtr + 1
            If Sheets("sheet1").Cells(Ndx, FieldPtr).Value <> "" Then
                MergeRec(1, FieldPtr) = Sheets("sheet1").Cells(Ndx, FieldPtr).Value
            End If
        Next Ndx
        DestRow = DestRow + 1
        
        'copy mergerec to sheet 2
        Sheet2.Cells(DestRow, 1).Resize(, 12) = MergeRec
        
        ' skip down to the next unique title
        CurrentRec = CurrentRec + TitleCount - 1
    Next CurrentRec
    
    'copy the header
    Sheet1.Range("a1").Resize(, 12).Copy Sheet2.Range("A1").Resize(, 12)
End Sub