How to copy the highlighted text from ColumnA to ColumnB, ColumnC

[SarahDetroja]

Hello There,

I want to copy the highlighted text from one column to other columns.

There are two options.
1) Highlighted text is "BOLD"
2) Highlighted text is "COLORED"

Ideal two separate solution each for "Bold" and "Color"
If either of one is not possible then please give any one solution.

Note1: I was told it's not possible using formula
Note2: In case of color, it can be hardcoded into the code so Red, Blue, Green (Even Hexadecimal). The only thing each color text should be copied to separate column

 

[DanteAmor]

Hi and welcome to MrExcel

I provide you the macro to extract the bold texts.
I hope someone else provides the second macro.

Sub Extract_Bold_Text()
  Dim a As Variant, b As Variant, c As Range
  Dim i As Long, j As Long, lr As Long, nMax As Double
  Dim m As String, una As Boolean, col As Long
  '
  lr = Range("A" & Rows.Count).End(3).Row
  nMax = Evaluate("MAX((LEN(A2:A" & lr & ")-LEN(SUBSTITUTE(A2:A" & lr & ","" "",""""))))") + 1
  ReDim b(1 To lr, 1 To nMax + 1)
  '
  For Each c In Range("A2:A" & lr)
    col = 1
    una = False
    i = i + 1
    For j = 1 To Len(c)
      m = Mid(c, j, 1)
      If c.Characters(j, 1).Font.Bold Then
        b(i, col) = b(i, col) & m
        una = True
      Else
        If una = True Then
          col = col + 1
          una = False
        End If
      End If
    Next j
  Next c
  Range("B2").Resize(lr, nMax).Value = b
End Sub

 

[SarahDetroja]

Hi DanteAmor,

You are a master class. It works perfectly. Thank you very much.

I am not sure about that. It would be great if you can help.

Thanks
Sarah

 

[SarahDetroja]

Hi DanteAmor,

Please don't worry now about color. Thank you very much again for your kind support.

I have noticed you normally the first to help especially new member which I am sure being appreciated by everyone.

Thanks again.

 

[DanteAmor]

News for you, I provide the second macro

Sub Extract_Color_Text()
  Dim a As Variant, b As Variant, c As Range
  Dim i As Long, j As Long, lr As Long, nMax As Double
  Dim m As String, una As Boolean, col As Long
  '
  lr = Range("A" & Rows.Count).End(3).Row
  nMax = Evaluate("MAX((LEN(A2:A" & lr & ")-LEN(SUBSTITUTE(A2:A" & lr & ","" "",""""))))") + 1
  ReDim b(1 To lr, 1 To nMax + 1)
  '
  For Each c In Range("A2:A" & lr)
    col = 1
    una = False
    i = i + 1
    For j = 1 To Len(c)
      m = Mid(c, j, 1)
      If c.Characters(j, 1).Font.Color <> vbNormal Then
        b(i, col) = b(i, col) & m
        una = True
      Else
        If una = True Then
          col = col + 1
          una = False
        End If
      End If
    Next j
  Next c
  Range("B2").Resize(lr, nMax).Value = b
End Sub

In case you have bold text or colored text in the same cell:

Sub Extract_BC_Text()
  Dim a As Variant, b As Variant, c As Range
  Dim i As Long, j As Long, lr As Long, nMax As Double
  Dim m As String, una As Boolean, col As Long
  '
  lr = Range("A" & Rows.Count).End(3).Row
  nMax = Evaluate("MAX((LEN(A2:A" & lr & ")-LEN(SUBSTITUTE(A2:A" & lr & ","" "",""""))))") + 1
  ReDim b(1 To lr, 1 To nMax + 1)
  '
  For Each c In Range("A2:A" & lr)
    col = 1
    una = False
    i = i + 1
    For j = 1 To Len(c)
      m = Mid(c, j, 1)
      If c.Characters(j, 1).Font.Bold Or _
         c.Characters(j, 1).Font.Color <> vbNormal Then
        b(i, col) = b(i, col) & m
        una = True
      Else
        If una = True Then
          col = col + 1
          una = False
        End If
      End If
    Next j
  Next c
  Range("B2").Resize(lr, nMax).Value = b
End Sub

 

[SarahDetroja]

Hi DanteAmor,

You are a genius. Appreciate your support.

Many thanks
Sarah

 

[DanteAmor]

Im glad to help you, thanks for the feedback.