Trying to Split a long string in same cell

[jw3837]

Thanks in advance for any help...

I have a column ("D") where each cell has a long string such as..

354fd32,63f453s45,457dd23,4s4,45rr665,4e54

I want to break it up at every 2nd comma displaying 2 sections at a time on a line but keeping the multiple lines in the same cell, all being visible. I dont want to do just a wrap ebcause that breaks up the data in the middle of a section.

I need to do this to the entire column via VBA. Can anyone help?

[rbrhodes]

Hi jw,

Try this on a COPY of your Workbook. It's admittedly 'brute force' but I tested it a bit.

It doesn't test for previous combinations of ", <space>" tho as you didn't mention that....it could...

Just need to uncomment REPLACE line in code.


Option Explicit
Sub Comma2Splitter()
Dim i As Long
Dim Roe As Long
Dim Colm As Long
Dim Comma As Long
Dim lastRow As Long
Dim tempCell As String
Dim splitCell As String
'//BEGIN USER CHANGE
'Change Column to suit (D = 4)
Colm = 4

'Change Row to start in suit
Roe = 1

'//END USER CHANGE

'Handle errors
On Error GoTo endo

'Speed
Application.ScreenUpdating = False

'Get last row of data
lastRow = Cells(65536, Colm).End(xlUp).Row

'Do all rows
For i = Roe To lastRow
'Get value
tempCell = Cells(i, Colm)

'To replace previous ",<space>" combinations uncomment next line.
' ie: remove '

'tempCell = Replace(tempCell, ", ", ",")

'Find first comma
Comma = InStr(tempCell, ",")
'If found
If Comma <> 0 Then
'Store first bit
splitCell = Left(tempCell, Comma)
'Parse
tempCell = Right(tempCell, Len(tempCell) - Comma)
'Keep going
Do
'Find next EVEN one
Comma = InStr(tempCell, ",")
If Comma <> 0 Then
'Store
splitCell = splitCell & Left(tempCell, Comma) & " "
'Parse
tempCell = Right(tempCell, Len(tempCell) - Comma)
'Find next ODD one
Comma = InStr(tempCell, ",")
'if found
If Comma <> 0 Then
'Store
splitCell = splitCell & Left(tempCell, Comma)
'Parse
tempCell = Right(tempCell, Len(tempCell) - Comma)
Else
'Bail
Exit Do
End If
Else
'OR only one ","
Exit Do
End If
'and going...
Loop
'Add remainder to split value
splitCell = splitCell & tempCell
'Put value without trailing space
Cells(i, Colm) = Trim(splitCell)
End If
nextcell:

'Do next one
Next i

'Reset
Application.ScreenUpdating = True
'Normal exit
Exit Sub
'Errored out
endo:
'Reset
Application.ScreenUpdating = True

'Inform User
MsgBox ("Error! " & Err.Number & " " & Err.Description)

End Sub

[malik641]

Nice code rbrhodes :thumb

One thing, I think jw3837 wanted them to be split up by a Line Feed rather than a space. So I would change:

splitCell = splitCell & Left(tempCell, Comma) & " "

' To this:
splitCell = splitCell & Left(tempCell, Comma) & vbLf

What's cool about this, too, is that it adjusts the height of the rows automatically.

[mikerickson]

This UDF uses a Carriage Return as the new delimiter. The formula =LineBrokenString(D1) , filled down, might serve your need.

Function LineBrokenString(commaDelimitedString As String) As String
Rem replaces every other comma with a carriage return
Dim subStrings As Variant, i As Long

subStrings = Split(commaDelimitedString, ",")
ReDim Preserve subStrings(UBound(subStrings) + 1)

For i = 0 To UBound(subStrings) - 1 Step 2
LineBrokenString = LineBrokenString & vbCr & subStrings(i) & "," & subStrings(i + 1)
Next i

If subStrings(i - 1) = vbNullString Then LineBrokenString = Left(LineBrokenString, Len(LineBrokenString) - 1)
End Function

[tstav]

Mike,
Although the Split allocates the substrings to array subStrings correctly, having set the Option Base to 1 (for whatever reasons), produces an error after the Redim Preserve because it cannot preserve the subStrings(0) item.
To cater for this, maybe the Redim should be like
ReDim Preserve subStrings(0 To UBound(subStrings) + 1)

Also the vbCr seems to show in the cells, while CrLf doesn't.

I liked your coding option very much.
Best regards, tstav

[Edit]: But I guess if anyone where to use your UDF in a formula in a cell, then my Option Base comment would be irrelevant.

[mdmackillop]

I did something like this to split between rows. A little tinkering and it should work within one cell
http://vbaexpress.com/kb/getarticle.php?kb_id=481

[RichardSchollar]

Hi

This is a variation using regular expressions - you will have to adjust the column width afterwards:

Sub Test()
Dim rng As Range, cell As Range
Set rng = Range("D1:D" & Cells(Rows.Count, "A").End(xlUp).Row)
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "(\w*\,\w*)(\,)"
For Each cell In rng
cell.Value = .Replace(cell.Value, "$1" & Chr(10))
Next
End With
rng.WrapText = True
End Sub

Richard