Loop to split text based on vbCrLf

[Brutusar]

Hi, I have written a code that should loop thru a column and if there is a cell with carriage return, it should split the text so the last row of text in the cell is moved to the next column, and the remaining text should be in one row.

Example:

The cell in row 1 should be like row 2.

Car make Volvo
Car make	Volvo

The code I have written is:

Sub SplitText()

    Dim cell As Range
    Dim str() As String

    For Each cell In Range("G1:G215")
        
            str = VBA.Split(ActiveCell.Value, vbCrLf)
        
            ActiveCell.Resize(1, UBound(str) + 1).Offset(0, 1) = str
       
    Next cell

End Sub

This code will move all text in the cell to the next column, so it is not very useful.

Any thoughts on what I am missing here?

 

[Fluff]

Are you looking to split just the text after the last line feed?

 

[mumps]

Try:

Sub SplitText()
    Application.ScreenUpdating = False
    Dim LastRow As Long, cel As Range
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each cel In Range("G1:G" & LastRow)
        cel.Offset(, 1) = Split(cel, Chr(10))(1)
        cel = Split(cel, Chr(10))(0)
    Next cel
    Application.ScreenUpdating = True
End Sub

 

[Brutusar]

My intention is to remove all text after the first line feed. The plan is to split the text after the last line feed and move the text to a different column, and then delete that column after the split has been done. But it may be better ways to do that.

 

[Fluff]

Ok, how about

Sub SplitText()
   Dim Cl As Range
   Dim Sp As Variant
   
   For Each Cl In Range("G1:G215")
      If Cl.Value <> "" Then
         Sp = Split(Cl.Value, vbLf)
         Cl.Resize(, UBound(Sp) + 1).Value = Sp
      End If
   Next Cl
End Sub

 

[Fluff]

Or if you are just trying to remove everything after the 1st line feed

Sub SplitText()
   Dim Cl As Range
   Dim Sp As Variant
   
   For Each Cl In Range("G1:G215")
      If Cl.Value <> "" Then
         Cl.Value = Split(Cl.Value, vbLf)(0)
      End If
   Next Cl
End Sub

 

[Brutusar]

The first code does the job exactly as I was planning, the second code is even better!

Thank you very much for your time and effort!!

 

[JEC]

Using arrays, for big datasets

Sub jec()
 Dim jv, it, ar As Variant, i As Long, y As Long, x As Long
 ReDim ar(214, 0)
 jv = Range("G1:G215")
 
 For i = 1 To UBound(jv)
    For Each it In Split(jv(i, 1), vbLf)
      ReDim Preserve ar(214, y): y = y + 1
      ar(i - 1, x) = it
      x = x + 1
    Next
   x = 0
 Next
 
 Range("G1").Resize(214, y) = ar
End Sub

 

[Fluff]

Glad we could help & thanks for the feedback.
If you only have one line feed in a cell, then you could do it without looping like

Sub SplitText()
    Range("G:G").TextToColumns Range("G1"), xlDelimited, , , False, False, False, False, True, vbLf, Array(Array(1, 1), Array(2, 9))

End Sub

 

[JEC]

Also one more array based method, to only keep the text before the first line feed

Sub jec()
 Dim ar As Variant, i As Long
 ar = Range("G1:G215")
 
 For i = 1 To UBound(ar)
    If Len(ar(i, 1)) Then ar(i, 1) = Split(ar(i, 1), vbLf)(0)
 Next

 Range("G1:G215") = ar
End Sub