Format bolded text only.

[juancarlos1]

Hi! First time posting here!
I have been struggling with a very specific and probably weird issue that I am not sure of having a solution.
The problem is related to text that is initially in word documents.
Likewise, I have today asked for advice in a forum connected to Word VBA:
www.office-forums.com/whats-new/posts/657604/

Meanwhile, I am thinking that perhaps it is better to paste the text I need to work on to Excel so that it is easier to manipulate
From what I have tried and tried a lot, coding in Word is kind of hellish in comparison, so exporting the text to excel seems to be the best.
Unfortunately for this specific problem, I am not having much more success in Excel.

I will expose the issue:

I have text sections in which a few words are bolded. The bolded words depend on the searched category.
For example, if I want to check fruits, and just fruits will already be bolded in the middle of the text (Solutions already in place).
Now with this text section needs further processing.
///Raw text example contained in cell A1:

Request ref#14587** include Banana, celery, bread, melon, base, bulb, Cucumber, grapes chocolate, cheese mango, mango cat food, carrot, and others several listed in subsequent ref.​

//Final text result expected to be included in cell A2:

Request ref#14587** include BANANA, celery, bread, MELON, base, bulb, Cucumber, GRAPES chocolate, cheese MANGO, MANGO cat food, carrot, MELON, and others several listed in subsequent ref.​

//Final text result expected to be included in cell A3:

BANANA, MELON, GRAPES, MANGO​

Actions required:
1-To use only the selected text section as the range so it doesn't affect other text sections in the document;
2-Trim spaces, including not leaving a space at the end of the sentences;
3-Remove paragraphs if existing;
4-Uppercase all bolded characters
5-List the bolded words, in a separate cell from the initial result cell, separated by a comma "," and remove duplicates just from this created text section;
6-Unbold the initially selected text from both result cells.

Can someone please advise if this is possible? Are there some tips or extra steps that I can follow to solve this conundrum?

 

[Zot]

I think you should have posted the part of macro that you've had currently o that helpers out here can continue base on that.

 

[Rick Rothstein]

Question: Will there ever be two bolded words next to each other with just a space between them?

 

[juancarlos1]

Hi @Zot , yes you're right. I did not post my code because although it is working, it has several annoying flaws. I am posting it here.
@Rick Rothstein , thank you for the question, yes this is exactly one of the problems I am trying to deal with, together bolded words.

My code (MS Word macro):

Sub Fdrpl()
Application.ScreenUpdating = False
Dim RanChar As Word.Range
Dim searchRange As Range
Selection.Font.Size = 11
Set searchRange = Selection.Range
Selection.EndKey Unit:=wdStory, Extend:=wdMove
Selection.Paragraphs.Add
Selection.Paragraphs.Add
Selection.Paragraphs.Add

    For Each RanChar In searchRange.Words
            If RanChar.Font.Bold = True Then
            RanChar.Font.AllCaps = True
            RanChar.Font.ColorIndex = wdRed
            RanChar.Select
            RanChar.Copy
            Selection.EndKey Unit:=wdStory
            Selection.PasteSpecial
            Selection.InsertAfter ","
            End If
            Next RanChar
                For Each RanChar In searchRange.Words
                If RanChar.Font.Bold = True Then
                RanChar.Select
                RanChar.Font.Bold = False
                End If
                    Next RanChar
                    
Selection.WholeStory
Dim RanChar2 As Range
Dim Strin1 As String
Dim RanChar3 As Range
Set RanChar3 = Selection.Range

    For Each RanChar2 In Selection.Words
    Strin1 = RanChar2.Text
    RanChar3.start = RanChar2.End
    
        With RanChar3.Find
        If RanChar2.Font.Bold = False Then GoTo NextIteration
        If RanChar2.Font.ColorIndex = wdBlack Then GoTo NextIteration
        If RanChar2.Text = " " Then GoTo NextIteration
        If RanChar2.Text = "," Then GoTo NextIteration
        If RanChar2.Text = ", " Then GoTo NextIteration

            .Text = Strin1
            .Replacement.Text = ""
            .Execute Replace:=wdReplaceAll
        End With
NextIteration:
        Next

Selection.WholeStory

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ",,"
        .Replacement.Text = ""
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " .,"
        .Replacement.Text = ""
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   With Selection.Find
        .Text = " ,"
        .Replacement.Text = ""
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
       With Selection.Find
        .Text = ", ."
        .Replacement.Text = ""
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
       With Selection.Find
        .Text = ",."
        .Replacement.Text = ""
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
        With Selection.Find
        .Text = " ."
        .Replacement.Text = ""
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
Dim RanChar4 As Word.Range
Dim searchRange2 As Range
Set searchRange2 = Selection.Range
     For Each RanChar4 In searchRange2.Words
     
        If RanChar4.Font.ColorIndex = wdRed Then
            RanChar4.Select
            RanChar4.Font.Bold = False
            RanChar4.Font.ColorIndex = wdBlack
        End If
 Next
    Application.ScreenUpdating = True
End Sub

Current issues that I was not able to solve:
-If the initial selection is the full text (Ctrl+A), an infinite loop is created, so I always need to add an extra paragraph at the bottom, before selecting my text and apply the macro.

-In the line created at the bottom:
- If in the initial text there are two words in a row, these will be at the bottom separated by a comma, and should not:
Banana, celery, bread, melon, base, Spanish Pears and others //// Will become at the bottom: BANANA, MELON, SPANISH, PEARS

- Similarly, because "Spanis Pears" is not being considered individually, the following happens:
Pears, celery, bread, melon, base, Spanish Pears and others //// Will become at the bottom: PEARS, MELON, SPANISH, ///// The word Pears disappeared....

- Also, if a word contains part of a previously checked word, this word section will be removed from the created bottom line:
Berries, celery, bread, melon, base, Cranberries and Elderberries, and others ////// Will become at the bottom: BERRIES, MELON, CRAN ELDER

-For some reason, when I copy the created texts from Ms Word to Excel, all words are pasted in lowercase (I need to paste them first to a Notepad, and from the Notepad to excel)

And finally, if someone could recommend a way of doing this in Excel, I would be grateful. I am not well familiarised with the options to make searches in text contained in one cell.
The only way I know how to do this in Excel is to separate all words into separate cells, apply conditions, and concatenate them back again.
Any advice?

 

[PeteWright]

Hello @juancarlos1

I have a working Excel File with VBA which you can download from my OneDrive.
There are two sheets
- Sheet1: the main user "interface" with a button
- Sheet2: the data containing all of your examples in column A plus some extra examples
In order to get the "program" work, go to Sheet1, click on the magic button and select your desired data cell (in Column A).
After the magic happens you'll be redirected automatically to Sheet1 in order to process more data.
If you want to take a look at the results simply go to Sheet2

This short video (screen capture) shows the working code.


Here is a Excel-only sheet (no VBA) with the sample data:

MrExcel_juancarlos1_bold_text.xlsm
	A
1	Request ref#14587** include Banana, celery, bread, melon, base, bulb, Cucumber, grapes chocolate, cheese mango, mango cat food, carrot, and others several listed in subsequent ref.
2	TestX, TestY and TestZ and a paragraph another paragraph
3	Test1, Test2 Test3
4	A, B C D
5	Banana, celery, bread, melon, base, Spanish Pears and others
6	Pears, celery, bread, melon, base, Spanish Pears and others
7	Berries, celery, bread, melon, base, Cranberries and Elderberries, and others
Sheet2

and here is my VBA code which you should place in a new module:

Option Explicit

Public Sub JustDoIt()
   'Enable Error Handling
   On Error GoTo ErrorHandler
  
   ' Variable definitions
   Dim temp, tmp As Variant 'temporary variable
   Dim rng As Range, rng2 As Range, rng3 As Range
   Dim cArr() As String 'Array with characters
   Dim aArr() As String 'Array with ASCII code of each character
   Dim wArr() As String 'Array with final keywords
   Dim resArr() As String 'result Array with unique keywords
   Dim pPos() As Long 'position of linfeed start
   Dim c, c2, c3, pN, bN As Long 'counter
   Dim p, p1, p2 As Long 'pivot
   Dim i, j As Long 'loop counter
   Dim l As Long, l2 As Long 'variables storing the length of characters
   Dim o 'object for loop

   'main routine start
   ThisWorkbook.Sheets("Sheet2").Activate
   Set rng = Application.InputBox("Enter or select cell", "Select single cell", "A1", , , , , 8)
   l = rng.Characters.count

   'copy cell content from selected cell to cell on the right
   Set rng2 = ThisWorkbook.Sheets("Sheet2").Cells(rng.Row, rng.Column + 1)
   rng.Copy
   rng2.PasteSpecial xlPasteAll
   l2 = rng2.Characters.count
   c = 0
   pN = 0

   'FOR LOOP #2: fill Array with characters
   ReDim cArr(l2 - 1)
   ReDim aArr(l2 - 1)
   For i = 0 To l2 - 1
      cArr(i) = rng.Characters(i + 1, 1).text
      aArr(i) = Asc(rng.Characters(i + 1, 1).text)
   Next i
  
   'FOR LOOP #3: counting linefeeds
   For Each o In aArr
      If o = 10 Then
         pN = pN + 1
      End If
   Next

   'FOR LOOP #4: set position of each linfeed start
   If pN > 0 Then
      ReDim pPos(pN - 1)
      p = 0
      For i = 0 To l2 - 1
         If Asc(rng2.Characters(i + 1, 1).text) = 10 Then
            pPos(p) = i + 1
            p = p + 1
         End If
      Next i
      For i = 0 To l2 - 1
         If Asc(rng2.Characters(i + 1, 1).text) = 10 Then
            rng2.Characters(i + 1, 1).Insert " "
         End If
      Next i
   End If

GoTo magicBegin
' MAGIC BEGIN ----------------------------------------
   temp = ""
magicBegin:
   If pN = 0 Then GoTo magicEnd
   p1 = LBound(pPos)
   p2 = UBound(pPos)
   GoTo magic1
magic1:
   rng2.Characters(pPos(p2), 1).Insert "  "
   GoTo magic3
magic2:
   rng2.Characters(pPos(p2), 1).Delete
   GoTo magic3
magic3:
   p2 = p2 - 1
   If p2 >= p1 Then GoTo magic2
   GoTo magicEnd
magicEnd:
' MAGIC END ------------------------------------------

   l2 = rng2.Characters.count
   For i = 1 To l2
      If rng2.Characters(i + 1, 1).text = " " _
         And rng2.Characters(i + 2, 1).text = " " Then
               rng2.Characters(i + 2, 1).Delete
               i = i - 1
      End If
   Next i

' SECOND MAGIC BEGIN ----------------------------------------
   l2 = rng2.Characters.count
   temp = ""
   c2 = 0
   c3 = 0
   p = 0
   bN = 0
  
   For i = 0 To l2 - 1
     
   Next i
  
   For i = 0 To l2 - 1
      If rng2.Characters(i + 1, 1).Font.Bold = True Then
         bN = bN + 1
         ReDim Preserve wArr(c2)
      Do While rng2.Characters(i + 1, 1).Font.Bold = True
         temp = temp & rng2.Characters(i + 1, 1).text
         Debug.Print temp
         i = i + 1
      Loop
      ReDim Preserve wArr(c2)
      wArr(c2) = UCase(temp)
      c2 = c2 + 1
      temp = ""
      End If

   Next i
  
   If bN > 0 Then
   For i = 1 To UBound(wArr)
      For j = 1 To UBound(wArr)
         If wArr(j) = wArr(j - 1) Then
            wArr(j) = "-"
         End If
      Next j
   Next i
   End If

' SECOND MAGIC END ------------------------------------------
  
   If bN > 0 Then
   temp = ""
   For Each o In wArr
      If o <> "-" Then
         If temp = "" Then
            temp = o
         Else
            temp = temp & ", " & o
         End If
      End If
   Next

   Set rng3 = ThisWorkbook.Sheets("Sheet2").Cells(rng2.Row, rng2.Column + 1)
   rng3.Value2 = temp
   End If



'Error Handling
ErrorHandler:
If rng Is Nothing Then MsgBox "Error. User cancelled!"

End Sub

 

[juancarlos1]

@PeteWright I can't say enough thank you! With video and all! I'll spend a lot of time going trough your code to understand it really :D
I especially like the trees it makes in the Immediate window!
It is working super well, there are only two issues:

Considering the following text:

Request ref#14587** include Banana, celery, bread, melon, base, bulb, Banana Cucumber, grapes chocolate, grapess cheese mango, mango cat food, carrot

The following happens:

I am guessing that the word Mango is duplicated in the result because of the comma "," so it is as if it was a different word.
In the second column the bolded words should be uppercased and unbolded:

If it is not too much trouble, can I ask if this is possible?

 

[PeteWright]

@juancarlos1 , hey here is something new.

Update: MrExcel_juancarlos1_bold_text-Rev1.xlsm

BTW, my VBA code is very greedy and depends on accurate text formatting.
For example, you could do the following:

wrong: mark a single word and the first following character and format them bold
right: mark a single word format it bold

wrong: mark a single word and the comma directly afterwards and format them bold
right: mark a single word and format it bold

wrong: mark two words and the space between them and format it all bold
right: mark two words, one after the other and format each bold

etc.

 

[juancarlos1]

Hi again @PeteWright , this is super awesome, can't thank you enough!
Yeah, sometimes it doesn't work on the first try. So I need to double-click on the text, and after it works on the same text, funny.
This is more than good really. I will find a way around this small detail. :D