Copy specific data from a row based on value in column A

[Paul_Hossler]

This is not very general purpose, but it works with your sample data

Option Explicit


Sub FormatData()
    Dim wsIn As Worksheet, wsOut As Worksheet
    Dim r As Long, c As Long
    Dim rData As Range
    
    Set wsIn = Worksheets("Before")
    Set wsOut = Worksheets("After")
    
    'copy input cells to output
    wsIn.Cells(1, 1).CurrentRegion.Copy wsOut.Cells(1, 1)
    
    'reference output cells
    Set rData = wsOut.Cells(1, 1).CurrentRegion
    
    'down the rows, starting at 2 until the end
    For r = 2 To rData.Rows.Count
        'accross the columns, starting at 4 untile the end
        For c = 4 To rData.Columns.Count
            'if the c-th cell in the r-th is blank, get the non-blank one to the right and put it there
            '   clear it afterwards
            If Len(rData.Cells(r, c).Value) = 0 Then
                rData.Cells(r, c).Value = rData.Cells(r, c).End(xlToRight).Value
                rData.Cells(r, c).End(xlToRight).ClearContents
            End If
        Next c
    Next r


    'delete columns that only have the headers left
    Set rData = wsOut.Cells(1, 1).CurrentRegion
    Do While Application.WorksheetFunction.CountA(rData.Columns(rData.Columns.Count)) = 1
        rData.Columns(rData.Columns.Count).EntireColumn.Delete
        Set rData = wsOut.Cells(1, 1).CurrentRegion
    Loop
End Sub