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]

Hi Guys,

Any help would be appreciated here.

Thanks,
Ansel

 

[Rick Rothstein]

Having to parse the cells one character at a time looking for bold characters can be time consuming. If all your bolded text are always separated by spaces... meaning no bold text is next to a non-space (such as a parenthesis, period, question mark, etc.), then we might be able to speed up the following a little, but until you confirm your data conforms to what I said, give this a try and see how timely it works for you...

[table="width: 500"]
[tr]
	[td]Sub BoldOnly()
  Dim X As Long, Txt As String, Data As Variant, Rng As Range, Cell As Range
  Const StartRow As Long = 2
  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
  Columns("B").TextToColumns , xlDelimited, , , False, False, False, True, False
End Sub[/td]
[/tr]
[/table]

 

[Nishiansel]

Hi Rick,

Thank you for the reply. I'll share a few sample text below

Commet Table Lamp 19"Ht. 19"Ht., 11 x 11 x 8.5 Copper Silk Shade.Size 11x8.5x11

Cousin Swarovski hotfix 5mmjet 22Pc

<tbody>
</tbody>

Dimensions (in Inch): 8 H x 8 W x 0.5 D
Twin-size 3Pc set: flat sheet 96x66(243x167cm), fitted sheet 75x39(190x99cm), 1 pillowcase 20x30(50x76cm)

Also, the code which you have given runs faster than the code I was using before. But then, while the code runs, excel freezes and then all of a sudden the macro is done. Is there any way to keep excel from freezing?

 

[Rick Rothstein]

Hi Rick,

Thank you for the reply. I'll share a few sample text below

Commet Table Lamp 19"Ht. 19"Ht., 11 x 11 x 8.5 Copper Silk Shade.Size 11x8.5x11

Cousin Swarovski hotfix 5mmjet 22Pc

<tbody>
</tbody>

Dimensions (in Inch): 8 H x 8 W x 0.5 D
Twin-size 3Pc set: flat sheet 96x66(243x167cm), fitted sheet 75x39(190x99cm), 1 pillowcase 20x30(50x76cm)

Is my code not giving you what you want for those examples? If not, please show me the output you actually want for them so I can see what you are actually looking for.

Also, the code which you have given runs faster than the code I was using before. But then, while the code runs, excel freezes and then all of a sudden the macro is done. Is there any way to keep excel from freezing?

No... as I said originally, "Having to parse the cells one character at a time looking for bold characters can be time consuming"... the code I posted runs faster because I do as much work in memory (rather than character by character on the sheet) as possible... the downside to that is Excel becomes unresponsive until all that memory work completes, then I "blast" the results to the worksheet all at once and then run the TextToColumns functionality on the column I blasted the results to. I could turn the mouse cursor to a "working" icon until all the work is done... would you want that added to the code?

 

[Nishiansel]

The code works perfect. Can you add bold to the output?

Also, turn the mouse cursor to "working" icon until the work is done.

 

[Rick Rothstein]

The code works perfect. Can you add bold to the output?

Also, turn the mouse cursor to "working" icon until the work is done.

This code should do it...

[table="width: 500"]
[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]
[/table]

 

[Ragnar1211]

Rick - Great solution... I'm earmarking this for future study

Nishiansel - adjust the for loop by adding DoEvents and a status update if you want to see what is happening and stop freezing (will be slightly slower)

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)
    DoEvents
    Application.StatusBar = "Currently Processing:  " & Cell.Address
  Next

 

[Ragnar1211]

Rick,

This line...

Mid(Txt, X) = " "

I never realized you could inline substitute text like that before... very useful, and so simple!

Thanks for the lesson

 

[Rick Rothstein]

Rick,

This line...

Mid(Txt, X) = " "

I never realized you could inline substitute text like that before... very useful, and so simple!

Thanks for the lesson

Yes, Mid comes in two forms... a function, which is the form you are familiar with, and a statement which is how I used it here. The replacement is single character for single character... you cannot replace a single character with the empty string ("") because that is not a character, and you cannot put two characters in for one, but you can specify 2 as the third argument and replace two adjacent characters with 2 characters of your choice. And, of course, you can specify 3 or 4 or more adjacent characters for replacement. And this "string stuffing" procedure is a very fast one.