Moving a column of text data into 3 columns of data?

Wrap Column To Rows

Option Explicit

Sub WrapColumnToRowsTEST()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim scell As Range: Set scell = wb.Sheets("Sheet1").Range("A2")
    Dim srg As Range: Set srg = RefColumnEnd(scell)
    If srg Is Nothing Then Exit Sub
    
    Dim dcell As Range: Set dcell = wb.Sheets("Sheet1").Range("C2")
    
    WrapColumnToRows srg, dcell, 3, 1

End Sub

Function RefColumnEnd(ByVal topCell As Range) As Range
    Const PROC_NAME As String = "RefColumnEnd"
    With topCell.Cells(1)
        Dim ws As Worksheet: Set ws = .Worksheet
        If ws.FilterMode Then ws.ShowAllData
        Dim RowsCount As Long: RowsCount = _
            ws.Cells(ws.Rows.Count, .Column).End(xlUp).Row - .Row + 1
        If RowsCount < 1 Then
            MsgBox "No data found in ""'" & ws.Name & "'!" _
                & .Resize(ws.Rows.Count - .Row + 1).Address(0, 0) & """!", _
                vbExclamation, PROC_NAME
            Exit Function ' no data
        End If
        Set RefColumnEnd = .Resize(RowsCount)
    End With
End Function

Sub WrapColumnToRows( _
        ByVal sourceSingleColumnRange As Range, _
        ByVal destinationTopLeftCell As Range, _
        ByVal DestinationColumnsCount As Long, _
        Optional ByVal RepeatItemsCount As Long = 0, _
        Optional ByVal PadWith As Variant = Empty)
    Const PROC_NAME As String = "WrapColumnToRows"
 
    ' Return the source values in the source array.
    Dim sData() As Variant, RowsCount As Long
    With sourceSingleColumnRange.Columns(1)
        RowsCount = .Rows.Count
        If RowsCount = 1 Then
            ReDim sData(1 To 1, 1 To 1): sData(1, 1) = .Value
        Else
            sData = .Value
        End If
    End With
    
    ' Define the destination array.
    ' Don't know the math behind it, but can't have more rows than the source.
    ' The final number of destination rows ('dRow') is determined in the loop.
    Dim dData() As Variant: ReDim dData( _
        1 To RowsCount, 1 To DestinationColumnsCount)
    
    ' Declare variables.
    Dim sRow As Long, dRow As Long, dCol As Long
    
    ' Arrange the source data in the destination array.
    dRow = 1
    For sRow = 1 To RowsCount
        DoEvents
        If dCol < DestinationColumnsCount Then ' write
            dCol = dCol + 1
            dData(dRow, dCol) = sData(sRow, 1)
        Else ' adjust
            sRow = sRow - RepeatItemsCount - 1
            dCol = 0
            dRow = dRow + 1
        End If
    Next sRow
    
    ' Pad with...
    For dCol = dCol + 1 To DestinationColumnsCount
        dData(dRow, dCol) = PadWith
    Next dCol
    
    ' Copy from the destination array to the destination range.
    With destinationTopLeftCell.Resize(, DestinationColumnsCount)
        Dim dws As Worksheet: Set dws = .Worksheet
        .Resize(dws.Rows.Count - .Row + 1).Clear
        .Resize(dRow).Value = dData
    End With
    
    ' Notify the user.
    MsgBox "A column of " & RowsCount & " wrapped to " _
        & dRow & " row" & IIf(dRow = 1, "", "s") & " by " _
        & DestinationColumnsCount & " column" _
        & IIf(DestinationColumnsCount = 1, "", "s") _
        & ", repeating " & RepeatItemsCount & " item" _
        & IIf(RepeatItemsCount = 1, "", "s") & ".", vbInformation

End Sub