Nishiansel
New Member
- Joined
- Apr 3, 2017
- Messages
- 5
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,
<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.
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.
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