Copy rows with different lengths into two columns

Question

I am trying to convert data from rows with different lengths into two columns.

The value of the first column remains equal to first cell of the row and is copied down to equal amount of rows as there are cells in the source row.

The second column is the rest of the cells of the source row copied and transposed to the second column.

Below is an example of what I wish to do.
Row length is max 18 cells and amount of rows may vary but is calculated in hundreds.

I found code here that is close to what I need.
Link: Copy Rows into columns using VBA

How do I change the code to a working solution?

Data format

Desired outcome

Start point

End result

Answer 1

It's brute force and ugly but quickest way I could write it.

Good for new users of VBA as it's the instructions you would give to a person to perform the task.

It would also be easy to adapt it to include your variable formatting.

Sub RearrangeNumbers()
Dim RowCnt As Integer       'rows of data to deal with
Dim ItemCnt As Integer      'number of number items in row
Dim RowActive As Integer    'Active Row
Dim tempRNG As Range        'range storage
Dim I As Integer            'Integer

    'Count Data Rows
RowCnt = Range("A" & Rows.Count).End(xlUp).Row

    'Set starting row
RowActive = 2

    'Cycle.
For I = 2 To RowCnt
    
    'Count items
    ItemCnt = Application.WorksheetFunction.CountA(Rows(RowActive)) - 1
    
    'Make sure there are more than 1 item(s)
    If ItemCnt > 1 Then
        
        'Make Space
        Rows(RowActive + 1 & ":" & RowActive + ItemCnt - 1).Insert Shift:=xlDown
        
        'Store number items as range
        Set tempRNG = Range(Cells(RowActive, 2), Cells(RowActive, ItemCnt + 1))
        
        'Paste that transposed range to sheet
        Range(Cells(RowActive, 2), Cells(RowActive + ItemCnt - 1, 2)) = Application.WorksheetFunction.Transpose(tempRNG)
        
        'Clear old data
        Range(Cells(RowActive, 3), Cells(RowActive, ItemCnt + 1)).ClearContents
        
        'Copy down first number
        Range(Cells(RowActive, 1), Cells(RowActive + ItemCnt - 1, 1)).FillDown
    End If
    
    'Relocate next data set
    RowActive = RowActive + ItemCnt
Next I

End Sub

Before:

After: