VBA Excel text to column data returns one row only

I am fighting with the code, which constantly returns one velue only. My amount of rows is flexible. Sometimes I have 10 sometimes 60, so i can't set the fixed range. The End(xlDown) doesn't help too.

To clarify roughly my problem I am showing the code and output image below:

 Sub Texttocolumns()
 Columns("E:E").Insert

 Range("E1") = "SAO"
 Range("D2", Range("D2).End(xlDown)).Texttocolumns _
 Destination:=Range("D2"), DataType:=xlDelimited, Space:=True
 Columns("D").AutoFit
 Range("D2", Range("D2").End(xlDown)).Copy
 Range("D2", Range ("D2").End(xlToRight).End(xlDown)).PasteSpecial _
 Paste:=xlPasteFormats
 Application.CutCopyMode = True

 End Sub

enter image description here

I tried another ways like, instead of Range("D2") I put Range("D"), what didn't work. The same as in Destination, where instead of Range("D2") I put Range("D2").End(xlDown), what triggered an error from debugger.

How can I make this whole list running properly?

2 answers

  • answered 2020-03-25 13:47 Mech

    This should do what you are looking for. I've commented so it should be clear but feel free to ask any follow up questions below.

     Sub Texttocolumns()
     Dim wb As Workbook: Set wb = ThisWorkbook
     Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
     Dim LastRow As Long
    
     ws.Columns("E:E").Insert
     LastRow = ws.Range("D" & ws.Rows.Count).End(xlUp).Row
    
     ws.Range("E1") = "SAO"
     ws.Range(ws.Cells(2, 4), ws.Cells(LastRow, 4)).Texttocolumns Destination:=ws.Cells(2, 4), DataType:=xlDelimited, Space:=True
     ws.Columns("D").AutoFit
     ws.Range(ws.Cells(2, 4), ws.Cells(LastRow, 4)).Copy
     ws.Cells(2, 4).PasteSpecial
    
     Application.CutCopyMode = True
    
     End Sub
    

  • answered 2020-03-25 16:33 VBasic2008

    A TextToColumns Ride

    The comments should help you change the code where I misunderstood. If not, feel free to ask for details in the comments below.

    Sub TextToCol()
    
        Const rowTitle As Long = 1        ' Title (Header) Row
        Const FR As Long = 2              ' First Record Row
        Const colSource As Long = 4       ' Source Column
        Const colTarget As Long = 5       ' Target Column
        Const strTitle As String = "SAO"  ' Target Column Title (Header)
    
        Dim rngCopy As Range              ' Source Record Range
        Dim rngPaste As Range             ' Paste Range
        Dim LR As Long                    ' Last Record Row
        Dim LC As Long                    ' Last Record Column
    
        ' Insert a new column (Target Column) after Source Column.
        Columns(colTarget).Insert
        ' Write Target Column Title.
        Cells(rowTitle, colTarget) = strTitle
    
        ' Calculate Last Record Row (from bottom to top) in Source Column.
        LR = Cells(Rows.Count, colSource).End(xlUp).Row
        ' Check if there are any records (data).
        If LR <= 1 Then MsgBox "No Records!": Exit Sub
        ' Calculate Source Record Range.
        Set rngCopy = Cells(FR, colSource).Resize(LR - FR + rowTitle)
    
        ' To avoid Excel complaining about data in cells when using TextToColumns,
        ' disable DisplayAlerts.
        Application.DisplayAlerts = False
    
            ' Apply TextToColumns on Source Record Range.
            rngCopy.TextToColumns Destination:=Cells(FR, colSource), _
              DataType:=xlDelimited, Space:=True
    
        ' Enable DisplayAlerts.
        Application.DisplayAlerts = True
    
        ' Apply Autofit on Source Column.and Target Columns.
        Columns(colSource).AutoFit
        ' Apply Autofit on Target Column.
        Columns(colTarget).AutoFit
    
        ' Calculate Last Record Column using Title Row.
        LC = Cells(rowTitle, Columns.Count).End(xlToLeft).Column
    
        ' Copy Source Record Range.
        rngCopy.Copy
    
        ' Calculate Paste Range.
        Set rngPaste = rngCopy.Offset(, colTarget - colSource) _
          .Resize(, LC - colTarget + 1)
    
        ' Paste formats of Source Record Range to Paste Range.
        rngPaste.PasteSpecial Paste:=xlPasteFormats
    
        ' Turn off CutCopyMode.
        Application.CutCopyMode = False
    
    End Sub