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?

 

[VBasic2008]

Split Cell Values to Rows

There are a few mistakes:
The line separator is most often (maybe always) vbLf, not vbCrLf, so the 'split' returns the same value.
You are writing to the next cell (.Offset(0, 1)) instead of the same cell (no offset).
You are not activating or selecting any cell, so each result will be written to the same cell which is to the right of whichever cell is active (215 times).

Option Explicit

Sub SplitCellValues()

    Const srgAddress As String = "G1:G10000"
    Const Delimiter As String = vbLf
    
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim srg As Range: Set srg = ws.Range(srgAddress)
    
    Dim sCell As Range ' Current Cell
    Dim sValue As Variant ' Current Value (we don't know what it is)
    Dim SubStrings() As String ' Current Substrings Array
    Dim UB As Long ' Current Substrings Array's Upper Limit
    Dim SplitCount As Long ' Number of Split Cells (Statistics)

    Application.ScreenUpdating = False
    
    For Each sCell In srg.Cells
        sValue = sCell.Value
        If Not IsError(sValue) Then ' skip if error value
            SubStrings = Split(CStr(sCell), Delimiter)
            ' 'UBound(SubStrings)' will return '- 1' if the string is
            ' an empty string (""), and '0' if no delimiter is found.
            If UBound(SubStrings) > 0 Then
                sCell.Resize(, UBound(SubStrings) + 1).Value = SubStrings
                SplitCount = SplitCount + 1
            End If
        End If
    Next sCell

    srg.EntireRow.AutoFit

    Application.ScreenUpdating = True

    MsgBox SplitCount & " cell values split.", vbInformation, "SplitCellValues"

End Sub

 

[Brutusar]

Thank you gentlemen!

 

[Rick Rothstein]

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

If this is all the OP wants to do, then no looping is needed...

Sub SplitText()
  Range("G1:G215").Replace vbLf & "*", "", xlPart, , , , False
  Range("G1:G215").Rows.AutoFit
End Sub

Note: The last line of code duplicates the autofitting of rows that your code does automatically.

 

[JEC]

Nice one!