Split cells by bold text

[dannyman1234]

Dear professionals,

I am a beginner in excel functions and macros.
I have a sheet full of names, addresses and phone numbers in one cell like this

Albert Young 16 teststreer 12C..................7888-6338

The name Albert Young is bold. The thing is I would like to split the cell putting the names in another colomn. Then it would be ideal to split the addresses and phone numbers as well. But I have no idea how to split any of these. I scanned this from a phone book, the dots are different on each row.

I hope someone can point me to the right direction,


Kind regards

Danny Gopie

 

[dannyman1234]

Thank you both Kenneth and Joe,


The last code from Kenneth seems to Work, the info is not consistent thats true.

I will check the code of Joe as well, but its 1.33 am now, need to get back to work early.

Regards

Danny

 

[oli82uk]

Hi,

We came up with a new method. this time splitting up any bold text into subsequent columns. hope it helps someone. It's a bit messy but have fun

Sub SplitAddress()
Dim cell As Range
Dim myLen As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer

Dim myString As String
Dim myName As String
Dim myAddress As String
Dim myPhone As String
Dim place As Boolean
Dim pos As Integer
Dim pos2 As Integer
Dim pos3 As Integer
Dim Posit As Integer
Dim BoldFound As Boolean
Dim CaptureText As String
Dim lnText As Integer

Posit = 1

' Split all entries in current selection
For Each cell In Selection
myName = ""
myAddress = ""
myPhone = ""
place = False
CaptureText = ""
BoldFound = True


myString = cell.Text
myLen = Len(myString)
If myLen > 0 Then

' Build name portion
For i = 1 To myLen
place = False
With cell.Characters(i, 1)
If .Font.Bold = True Then
myName = myName & Mid(myString, i, 1)
place = True
Else

BoldFound = False
CaptureText = CaptureText & Mid(myString, i, 1)

End If
End With
If place = True And BoldFound = False Then
' MsgBox CaptureText

BoldFound = True
pos = i
lnText = Len(myName) - 1
'MsgBox Left(myName, lnText)
cell.Offset(0, Posit) = Left(myName, lnText) & CaptureText
CaptureText = ""
myName = Mid(myName, lnText + 1, 1)
Posit = Posit + 1
End If
Next i
cell.Offset(0, Posit) = myName + CaptureText
CaptureText = ""
myName = ""


End If
Posit = 1
Next cell

End Sub