Find & Extract Text

Brad

In the attached revision to your file, I've added the code below to Module 1. It can be triggered from the form button labelled "Extract only bold and underlined text" on the sheet Table 1.

It runs through the range defined in the first line in bold below. The later sub-loop (also in bold) goes through each character in a cell's text and, if bold or underlined, adds it to an output string called Ext. That string gets tested after a cell is done and is added to column A of a second sheet called Extract.

The code is commented (ahead of the action) to explain broadly what is happening:

Sub Extract()

Dim Ext As String, Cl As Range, n As Long

Set SourceRange = Sheet1.Range("A1:W65") ' change to suit but not too large!

On Error Resume Next

' clear results and add title
With Worksheets("Extract")
    .UsedRange.ClearContents
    .Range("A1").Value = "Extract from " & SourceRange.Address & " created " & Now
    .Range("A1").Font.Bold = True
End With

' reduce processing time
Application.ScreenUpdating = False

'check cells in SourceRange
For Each Cl In SourceRange
    'reset output string
    Ext = ""
    'avoid a problem when cell is just a bold/underlined number
    If IsNumeric(Cl.Value) Then
        If Cl.Font.Underline = 2 Or Cl.Font.Bold = True Then Ext = Cl.Value
        ' skip down
        GoTo ContinueForEachloop
    End If
    ' otherwise loop through characters in string
    For n = 1 To Len(Cl.Text)
        With Cl.Characters(n, 1)
            If .Font.Underline = 2 Then
            ' add to output string
                Ext = Ext + .Text
            Else
                If .Font.Bold = True Then Ext = Ext + .Text
            End If
        End With
    Next n

ContinueForEachloop:

    ' if there's an output, write to next row on Extract sheet
    If Ext <> "" Then
        With Worksheets("Extract")
            ' find last populated row
            LastRw = .Cells(.Rows.Count, 1).End(xlUp).Row
            .Cells(LastRw + 1, 1).Value = Ext
        End With
    End If

Next Cl
' restore
Application.ScreenUpdating = True
' tell user
MsgBox "Extracted only bold and underlined text from " & SourceRange.Address & " to Extract sheet "


End Sub

Note however that this code isn't perfect- SourceRange is set to  A1:W65 (1,495 cells) above since it seems to hang if the range includes cells A70 or A79 (for example) but if you set SourceRange to just one of those cells, the macro runs okay. I'm pretty it's not a string length issue so it might be a memory issue on my old PC. Please let me know if you encounter similar problems. 

Giving you this code isn't to say I think it's a good study aid (though it might be handy as an intro or to recap)- personally I like details and think that knowing a subject in depth is preferable to just knowing the headlines!

Hope this gives you a good start.