Extract Bold Word from String

danbrown

New Member
Joined
Feb 2, 2017
Messages
42
Hi Guys
I need a simple code to extract a bolded word from a string in a cell.It then places this text in column b and the entire string in column C.Then it moves to next cell in range.
Eg:

Column A
extract THIS
skip thisand this
HERE
is done

Should like this:
Columnn B Column C
THIS extract THIS
HERE HERE is done

To prove im not one of those 'script-kiddies' ive added my code.
Since im not familiar with split function,I use characters ppt instead.

Code:
Dim rng as Range,counter as integer
Set rng = Range("a1:a4")
counter = 0
For each cell in rng
    For i = 1 to len(cell.text)
        If cell.font.character(i,1).bold = True Then
        Cells(counter + 1,2).value = [U][I]'Extracted word/chars'[/I][/U]
        Cells(counter + 1,3).value = Cell.value 
        End If
    Next i
counter = counter + 1
Next cell

Thanks in advance!
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
Hi
Welcome to the board

This is a solution to get you started:

Code:
Sub ExtractBold()
Dim r As Range, rC As Range
Dim lCounter As Long, i As Long
Dim sExtract As String
Dim bHasBold As Boolean

Set r = Range("A1:A4")

For Each rC In r
    sExtract = ""
    bHasBold = False
    ' if the cell has a bold word extract it to a string variable
    For i = 1 To Len(rC.Value)
        If rC.Characters(i, 1).Font.Bold Then
            bHasBold = True
            sExtract = sExtract & Mid(rC.Value, i, 1)
        End If
    Next i
    ' if a bold word was found in the cell copy it as well as the whole cell to columns B and C
    If bHasBold Then
        lCounter = lCounter + 1
        Range("B" & lCounter).Value = sExtract
        rC.Copy Destination:=Range("C" & lCounter)
    End If
Next rC

End Sub
 
Upvote 0
Hi
Welcome to the board

This is a solution to get you started:

Code:
Sub ExtractBold()
Dim r As Range, rC As Range
Dim lCounter As Long, i As Long
Dim sExtract As String
Dim bHasBold As Boolean

Set r = Range("A1:A4")

For Each rC In r
    sExtract = ""
    bHasBold = False
    ' if the cell has a bold word extract it to a string variable
    For i = 1 To Len(rC.Value)
        If rC.Characters(i, 1).Font.Bold Then
            bHasBold = True
            sExtract = sExtract & Mid(rC.Value, i, 1)
        End If
    Next i
    ' if a bold word was found in the cell copy it as well as the whole cell to columns B and C
    If bHasBold Then
        lCounter = lCounter + 1
        Range("B" & lCounter).Value = sExtract
        rC.Copy Destination:=Range("C" & lCounter)
    End If
Next rC

End Sub

Works like a charm!Thank u so much
 
Upvote 0

Forum statistics

Threads
1,213,544
Messages
6,114,249
Members
448,556
Latest member
peterhess2002

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top