TextToColumns deleting contents after cells with no delimiter

[blueangel2323]

Hi everyone, I have a big problem here and it would be greatly appreciated if anyone could help me.

Let's say that I have the following code:

Columns("A:A").TextToColumns Destination:=Range("A1")

and I'm using commas as delimiters. I run the script on the following data:

A2: Gobble,Turkey,Dinner     B2: (blank)     C2: (blank)
A3: Gobble                   B3: Hello       C3: Everybody

The results would look something like this:

A2: Gobble     B2: Turkey     C2: Dinner
A3: Gobble     B3: (blank)    C3: (blank)

The first line (row 2) is fine, that's exactly what TextToColumns is supposed to do.

The problem is with the second line (row 3). The cells after A3 were replaced by blank cells, even though I want to keep "Hello" and "World"

Is there a way to tell the script not to replace cells that are already occupied, or better yet, to skip cells (in column A) that have no delimiter?

 

[mvptomlinson]

There's no way to change the functionality of the built-in TextToColumns method. You would need to write a custom macro to do so. Probably loop through each cell in column A, check if there is a delimiter, check if there's already text in adjacent columns and skip, etc.

 

[Darkspartan]

As a work around,

If your data is consistent (always has two delimiters) then you could insert columns and delete the empty cells

 

[markmzz]

Try this code:

IMPORTANT: DO SOME TESTS WITH A COPY OF YOUR WORKBOOK.

Sub TextColumns()
    Dim myCell As Range
    Dim myMax, myComma, myRow As Long
 
    For Each myCell In Range("A:A")
        myComma = Len(myCell) - Len(Replace(myCell, ",", ""))
        If myMax < myComma Then
            myMax = myComma
        End If
        If myCell.Value = "" Then
            myRow = myCell.Row - 1
            Exit For
        End If
    Next myCell
 
    Range(Cells(1, 2), Cells(1, myMax + 1)).EntireColumn.Insert
 
    Columns("A:A").TextToColumns _
        Destination:=Cells(1, 1), _
        DataType:=xlDelimited, _
        Comma:=True
 
    Range(Cells(1, 1), Cells(myRow, myMax + 1)). _
        SpecialCells(xlCellTypeBlanks).Select
 
    Selection.Delete Shift:=xlToLeft
End Sub

Markmzz

 

[Rick Rothstein]

Here is a macro which should produce the end results you are looking for..

Sub TTC()
  Dim X As Long, Arr() As String
  Const StartRow As Long = 2
  Const SearchColumn As String = "A"
  Const Delimiter As String = ","
  For X = StartRow To Cells(Rows.Count, SearchColumn).End(xlUp).Row
    Arr = Split(Cells(X, SearchColumn).Value, Delimiter)
    If UBound(Arr) > 0 Then Cells(X, SearchColumn).Resize(, UBound(Arr) + 1) = Arr
  Next
End Sub

 

[blueangel2323]

Here is a macro which should produce the end results you are looking for..

Sub TTC()
  Dim X As Long, Arr() As String
  Const StartRow As Long = 2
  Const SearchColumn As String = "A"
  Const Delimiter As String = ","
  For X = StartRow To Cells(Rows.Count, SearchColumn).End(xlUp).Row
    Arr = Split(Cells(X, SearchColumn).Value, Delimiter)
    If UBound(Arr) > 0 Then Cells(X, SearchColumn).Resize(, UBound(Arr) + 1) = Arr
  Next
End Sub

That works perfectly, thank you so much!