CODEWITHSUNDEEP
excelvba
Geographos
Geographos

Reputation: 1476

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?

Upvotes: 1

Views: 584

Answers (2)

VBasic2008
VBasic2008

Reputation: 54815

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

Upvotes: 1

Mech
Mech

Reputation: 4015

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

Upvotes: 1

Related Questions