Text to columns for multiple columns - Excel VBA

Question

I have many columns of concatenated data that I would like to split by spaces.

So from this:

To this:

This VBA code is very close,

    Sub TextToColumns()

'Deines Last Row
    Dim LastRow As Long
    LastRow = 1048576 'the last row possible in excel
    'optional alternative **LastRow** Code
       'Counts number of rows (counts from last row of Column A):
         'Dim LastRow As Long
         'LastRow = Cells(Rows.Count, "A").End(xlUp).Row

'Counts number of Columns (my headers start in row 1)
    Dim LastColumn As Long
    LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column

'Loops Text to columns
    Dim StartingRow, StartingColumn As Long
    StartingRow = 1

    For StartingColumn = 1 To LastColumn
        Range(Cells(StartingRow, StartingColumn), Cells(LastRow, StartingColumn)).Select

        Selection.TextToColumns , DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True

    Next

End Sub

but I would like to use it only on the selected cells, and it overwrites the data to give this:

How can I avoid overwriting the data, and only run the macro on selected cells? Thank you very much.

If you only want to do this for certain columns you could use an inputfield to do so. Then for every column that is in the input field you insert two columns, and do the split. Then do the next column. Do this backwards!! — Luuklag, Jun 25 '19 at 06:29

score 1 · Accepted Answer · answered Jun 25 '19 at 08:23

Try this code. Basicly what it does is that it loops throug the selected rows and merge all the text in each sell of the column into a string, then it splits it up into each cell in the column with space as a delimiter.

Remember to select some rows before running the macro.

Sub TextToColumns()

'Counts number of Columns (my headers start in row 1)
    Dim LastColumn As Long
    LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column


'Full strig
    Dim FullString As Variant
'Split string
    Dim SplitString As Variant


'Loops Text to columns

   Dim rng As Range
   Dim lRowSelected As Long
   For Each rng In Selection.Rows

    RowsSelected = rng.Row


        'Making one string from all the cells in the row
        For StartingColumn = 1 To LastColumn

        If StartingColumn = 1 Then

        FullString = Cells(RowsSelected, StartingColumn).Value

        Else

        FullString = FullString & " " & Cells(RowsSelected, StartingColumn).Value
        End If


        Next StartingColumn

            'Splits the string up into each cell with space as a delimiter
            SplitString = Split(FullString, " ")

            For i = 0 To UBound(SplitString)
                Cells(RowsSelected, i + 1).Value = SplitString(i)
                Next i

   Next rng


End Sub

score 1 · Answer 2 · answered Jun 25 '19 at 11:22

I would

concatenate your original rows into one, with a space delimiter
and then split that result on the space.

The code below gives you the results you show in your to this: screenshot from your original data.

Option Explicit
Sub splitMultipleColumns()
    Dim wsSrc As Worksheet, rSrc As Range, rDest As Range
    Dim vSrc As Variant
    Dim vConcat As Variant
    Dim I As Long, J As Long

'Many ways to do this
Set wsSrc = Worksheets("sheet1")
Set rSrc = wsSrc.Cells(1, 1).CurrentRegion

'put results below original, but they could go anyplace
Set rDest = rSrc.Offset(rSrc.Rows.Count + 2).Resize(columnsize:=1)

vSrc = rSrc 'read into array for processing speed

'create array of concatenated rows
ReDim vConcat(1 To UBound(vSrc, 1), 1 To 1)
For I = 1 To UBound(vSrc, 1)
    For J = 1 To UBound(vSrc, 2)
        vConcat(I, 1) = vConcat(I, 1) & " " & vSrc(I, J)
    Next J
    vConcat(I, 1) = Trim(vConcat(I, 1))
Next I

Application.ScreenUpdating = False

rDest.EntireRow.Clear
rDest = vConcat
rDest.TextToColumns DataType:=xlDelimited, consecutivedelimiter:=True, _
    Tab:=False, semicolon:=False, comma:=False, Space:=True, other:=False

'Fix the Header row
Set rDest = rDest.CurrentRegion
With rDest
    For J = .Columns.Count To 4 Step -1
        If .Item(1, J) <> "" Then
            Range(rDest(1, J), rDest(1, J + 1)).Insert (xlShiftToRight)
        End If
    Next J
    rDest.Style = "Output"
End With

End Sub

Text to columns for multiple columns - Excel VBA

2 Answers2

Linked