CODEWITHSUNDEEP
vbams-word
kellie A
kellie A

Reputation: 3

Sub to find text in a Word document by specified font and font size

Goal: Find headings in a document by their font and font size and put them into a spreadsheet.

All headings in my doc are formatted as Ariel, size 16. I want to do a find of the Word doc, select the matching range of text to the end of the line, then assign it to a variable so I can put it in a spreadsheet. I can do an advanced find and search for the font/size successfully, but can't get it to select the range of text or assign it to a variable.

Tried modifying the below from http://www.vbaexpress.com/forum/showthread.php?55726-find-replace-fonts-macro but couldn't figure out how to select and assign the found text to a variable. If I can get it assigned to the variable then I can take care of the rest to get it into a spreadsheet.

'A basic Word macro coded by Greg Maxey
Sub FindFont

Dim strHeading as string
Dim oChr As Range

  For Each oChr In ActiveDocument.Range.Characters
    If oChr.Font.Name = "Ariel" And oChr.Font.Size = "16" Then
      strHeading = .selected
  Next

lbl_Exit:
  Exit Sub

End Sub

Upvotes: 0

Views: 1539

Answers (1)

Sam
Sam

Reputation: 381

To get the current code working, you just need to amend strHeading = .selected to something like strHeading = strHeading & oChr & vbNewLine. You'll also need to add an End If statement after that line and probably amend "Ariel" to "Arial".

I think a better way to do this would be to use Word's Find method. Depending on how you are going to be inserting the data into the spreadsheet, you may also prefer to put each header that you find in a collection instead of a string, although you could easily delimit the string and then split it before transferring the data into the spreadsheet.

Just to give you some more ideas, I've put some sample code below.

Sub Demo()
    Dim Find As Find
    Dim Result As Collection
    
    Set Find = ActiveDocument.Range.Find
    
    With Find
        .Font.Name = "Arial"
        .Font.Size = 16
    End With

    Set Result = Execute(Find)
    
    If Result.Count = 0 Then
        MsgBox "No match found"
        Exit Sub
    Else
        TransferToExcel Result
    End If
End Sub

Function Execute(Find As Find) As Collection
    Set Execute = New Collection
    
    Do While Find.Execute
        Execute.Add Find.Parent.Text
    Loop
End Function

Sub TransferToExcel(Data As Collection)
    Dim i As Long
    
    With CreateObject("Excel.Application")
        With .Workbooks.Add
            With .Sheets(1)
                For i = 1 To Data.Count
                    .Cells(i, 1) = Data(i)
                Next
            End With
        End With
        .Visible = True
    End With
End Sub

Upvotes: 2

Related Questions