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

 

[Joe4]

WELCOME TO THE BOARD!

To split the cell based on bolding will most likely require the use of VBA.

However, splitting the phone number off should be pretty easy. Just:
1. Highlight the column
2. Go to the Data menu and select Text-to-Columns
3. Select the Delimited option and click Next
4. Check the Other box, and enter a period in the box next to Other.
5. Check the box that says "Treat consecutive delimiters as one"
6. Click Finish

 

[dannyman1234]

Thanks a lot! That worked,

The only problem here is that the address also becomes bold.

Is there a way of getting around this? or do I need a vb script for this as well?

Kind regards

Danny

 

[Joe4]

I think you can just select the whole column and unbold it, if you do not want the bolding.

I thought maybe I could write a macro to split the cells based on what part is bold and what part isn't, but I am having a bit of trouble with that. What is making it difficult is that only part of the cell is bold, not the whole thing.

 

[dannyman1234]

Thanks Joe,

I only need the bolding, in order to seperate the names and addresses, otherwise I dont need it. I found a thread here, but i can't get it to work

http://www.ozgrid.com/forum/showthread.php?t=71459

My knowledge is limited in writing macro's or UDF's but im trying to learn

thanks

Danny

 

[Kenneth Hobson]

Select the cells to the right of the strings to parse right and play.

Sub Split3()
  Dim cell As Range, sCell As Range, cell2 As Range
  Dim s As String, sVal As String
  Dim bBold As Boolean
  Dim i As Integer
  
  'Bold part - name
  For Each cell In Selection
    s = ""
    Set sCell = cell.Offset(0, -1)
    sVal = sCell.Value
    For i = 1 To Len(sCell.Value)
      If sCell.Characters(i, 1).Font.Bold = True Then
        s = s + Mid(sVal, i, 1)
      End If
    Next i
    cell.Value = s
    
    'Split to Address and Phone parts
    Set cell2 = cell.Offset(0, 1)
    cell2.Value = Right(sCell.Value, Len(sCell.Value) - Len(s) - 1)
    cell2.TextToColumns Destination:=cell2, DataType:=xlDelimited, _
      TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
      Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
      :=".", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Next cell
End Sub

 

[Joe4]

Danny,

That link to OzGrid gave me the piece I needed. I put some code together. I am sure it is not the most efficient piece of code, but it does seems to work. There are instructions at the beginning of the code.

Hopefully between my code and Kenneth's code, you will have something that works for you.

Sub SplitAddress()
'   Directions:
'       1.) Insert three blank columns to the right of your column of data
'       2.) Format the three new blank columns as Text
'       3.) Highlight the column of data you want to split (just the cells with data)
'       4.) Run this VBA code

    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
    

'   Split all entries in current selection
    For Each cell In Selection
        myName = ""
        myAddress = ""
        myPhone = ""
        
        myString = cell.Text
        myLen = Len(myString)
        If myLen > 0 Then

'   Build name portion
            For i = 1 To myLen
                With cell.Characters(i, 1)
                    If .Font.Bold = True Then
                        myName = myName & Mid(myString, i, 1)
                    Else
                        j = i + 1
                        Exit For
                    End If
                End With
            Next i

'   Build address portion
            For i = j To myLen
                If Mid(myString, i, 1) = "." Then
                    k = i + 1
                    Exit For
                Else
                    myAddress = myAddress & Mid(myString, i, 1)
                End If
            Next i

'   Build phone portion
            For i = k To myLen
                If Mid(myString, i, 1) = "." Then
                Else
                    myPhone = myPhone & Mid(myString, i, 1)
                End If
            Next i
        
'   Enter values in correct cells
            cell.Offset(0, 1) = myName
            cell.Offset(0, 2) = myAddress
            cell.Offset(0, 3) = myPhone
    
        End If
    Next cell

End Sub

 

[dannyman1234]

Thanks a lot for your reply Kenneth,

It works almost perfect. The first 2 rows are good. But after that, it splits the name correctly, but in each folowing rules it removes the first letter of the address.

Albert young churchstreet 11/77 ....

will become

Albert young | hurchstreet 11/77

Is this possible to solve?

 

[Kenneth Hobson]

I could not duplicate the problem. You can try posting a few but I may need an actual xls to see what is happening. I find mediafire.com an easy site to post and share files.

I tested 6 rows and it was fine. I thought it might be best to turn off displayalerts.

Sub Split3()
  Dim cell As Range, sCell As Range, cell2 As Range
  Dim s As String, sVal As String
  Dim bBold As Boolean
  Dim i As Integer
  
  Application.DisplayAlerts = False
  'Bold part - name
  For Each cell In Selection
    s = ""
    Set sCell = cell.Offset(0, -1)
    sVal = sCell.Value
    For i = 1 To Len(sCell.Value)
      If sCell.Characters(i, 1).Font.Bold = True Then
        s = s + Mid(sVal, i, 1)
      End If
    Next i
    cell.Value = s
    
    'Split to Address and Phone parts
    Set cell2 = cell.Offset(0, 1)
    cell2.Value = Right(sCell.Value, Len(sCell.Value) - Len(s) - 1)
    cell2.TextToColumns Destination:=cell2, DataType:=xlDelimited, _
      TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
      Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
      :=".", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Next cell
    Application.DisplayAlerts = False
End Sub

 

[Kenneth Hobson]

Your problem may be that your data is not consistent. Trim might help in that case.

Sub Split3()
  Dim cell As Range, sCell As Range, cell2 As Range
  Dim s As String, sVal As String
  Dim bBold As Boolean
  Dim i As Integer
  
  Application.DisplayAlerts = False
  'Bold part - name
  For Each cell In Selection
    s = ""
    Set sCell = cell.Offset(0, -1)
    sVal = sCell.Value
    For i = 1 To Len(sCell.Value)
      If sCell.Characters(i, 1).Font.Bold = True Then
        s = s + Mid(sVal, i, 1)
      End If
    Next i
    cell.Value = s
    
    'Split to Address and Phone parts
    Set cell2 = cell.Offset(0, 1)
    cell2.Value = Trim(Right(sCell.Value, Len(sCell.Value) - Len(s)))
    cell2.TextToColumns Destination:=cell2, DataType:=xlDelimited, _
      TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
      Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
      :=".", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Next cell
    cell2.Offset(0, 1).Value = Trim(cell2.Offset(0, 1))
    Application.DisplayAlerts = False
End Sub