Letters in bold from a sentence in a cell and pasting in adjacent cells

[Nishiansel]

Hi Guys,

I need a VBA code to take the words in bold in a cell and paste it in the adjacent cells.

For example,

Column A	Bold	Bold	Bold
I am new to the group	group
I came home late last evening	I	home	evening

<tbody>
</tbody>

I currently took a code from the forum and tweaked it a bit. The issue I am facing here is, the code runs well but is time consuming. It takes more than 20 mins for 500 rows. I will be running it for 15000 rows. Kindly suggest a better code or enhance the below code.

Option Explicit
Public subname As String
Sub progbar_uf()
subname = "FindBoldCharacters"
UserForm1.Show
End Sub
Sub UpdateProgressBar(Pctdone As Single)
    With UserForm1
        .FrameProgress.Caption = Format(Pctdone, "0%")
        .LabelProgress.Width = Pctdone * _
            (.FrameProgress.Width - 10)
    End With
    DoEvents
End Sub

Sub FindBoldCharacters()
    Dim Pctdone As Single
    Dim StrChr As String
    Dim i As Integer
    Dim c As Range
    Dim BoldWord As String
    Dim iCol As Integer
    Application.ScreenUpdating = False
    Range("B:IV").ClearContents
    For Each c In Range("a1", Range("a15000").End(xlUp))
        iCol = 2
        For i = 1 To Len(c)
            If Asc(c.Characters(i, 1).Text) = 32 Then
                If Cells(c.Row, iCol) <> "" Then
                    iCol = iCol + 1
                End If
                Cells(c.Row, iCol) = Trim(BoldWord)
                Cells(c.Row, iCol).Font.FontStyle = "Bold"
                BoldWord = ""
            ElseIf c.Characters(i, 1).Font.Bold = True Then
                BoldWord = BoldWord & c.Characters(i, 1).Text
            End If
        Next i
        'case end word was bold
        If Len(BoldWord) <> 0 Then
            If Cells(c.Row, iCol) <> "" Then
                iCol = iCol + 1
            End If
            Cells(c.Row, iCol) = Trim(BoldWord)
            Cells(c.Row, iCol).Font.FontStyle = "Bold"
            BoldWord = ""
        End If
    Pctdone = i / iCol
    UpdateProgressBar (Pctdone)
    Next c
    Unload UserForm1
    MsgBox "Done"
End Sub

 

[Nishiansel]

This code should do it...

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub BoldOnly()
  Dim X As Long, LastCol As Long, Txt As String, Data As Variant, Rng As Range, Cell As Range
  Const StartRow As Long = 2
  Application.Cursor = xlWait
  Set Rng = Range(Cells(StartRow, "A"), Cells(Rows.Count, "A").End(xlUp))
  Data = Rng
  For Each Cell In Rng
    Txt = Replace(Data(Cell.Row - StartRow + 1, 1), Chr(160), " ")
    For X = 1 To Len(Txt)
      If Not Cell.Characters(X, 1).Font.Bold Then
        Mid(Txt, X) = " "
      End If
    Next
    Data(Cell.Row - StartRow + 1, 1) = Application.Trim(Txt)
  Next
  Cells(StartRow, "B").Resize(UBound(Data), 1) = Data
  LastCol = Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
  Cells(StartRow, "B").Resize(UBound(Data), LastCol).Font.Bold = True
  Columns("B").TextToColumns , xlDelimited, , , False, False, False, True, False
  Application.Cursor = xlDefault
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

Thanks for the code Rick. It was really helpful. However, in one of the cases, I found that a symbol in bold was not brought to the next cell. Please check below for more details.

"19 Bonanzaville" Art Print by Gordon Semmens -

In the above item, the double quot(") and hyphen(-) are in bold. But, the code shows takes the hyphen(-) to the next cell and not the quot("). Any idea why this happens? and could you suggest a way that it brings everything in bold to the next cell?