VBA从Excel获取Word文档中样式的所有出现

Question

For my work I have to find all the instances of a style in 40 word documents (.doc). Once I get the text, I want to write it in a cell in my excel sheet (.xls).

With the code I wrote I can get the first instance of that style but I cannot get the next one, it goes into an infinite loop and I don't now why (there are about 10 occurrences on each file).

Could you tell me where I am wrong?

I want to go from that: Before running the macro to that: After running the macro

Here is my code:

'==================================================================
' Declarations
'==================================================================

Dim ObjWord As Object ' Word application object

'==================================================================
' Macro
'==================================================================

Public Sub Macro()

Dim row As Integer
row = 9 'first available row

Set ObjWord = CreateObject("word.application")

Worksheets("Sheet 2").Activate

While (Cells(row, 2).Value <> "End of file list")

    Set file = ObjWord.documents.Open(ThisWorkbook.path & ".\" & Cells(row, 1).Hyperlinks(1).Address)


    Set currentRange = file.Range

    currentRange.Find.ClearFormatting
    currentRange.Find.Forward = True
    currentRange.Find.Text = ""
    currentRange.Find.Style = "MyStyle"
    bFind = currentRange.Find.Execute

    Do While bFind 'here is the endless loop
         row = row + 1
         StyleValue= currentRange.Text 'I get stuck with the first value :-(
         Rows(row).EntireRow.Insert
         Cells(row, 2).Value = StyleValue
         bFind = currentRange.Find.Execute
    Loop

    file.Close

    row = row + 1 ' next File
Wend

ObjWord.Quit
End Sub

Answer 1

I think it needs to be this:

Do While currentRange.Find.Found 
    currentRange.Find.Execute 
Loop 

Answer 2

I had to make a number of changes to get it to work for me, mostly because I have Option Explicit on and declare all variables.

However while going through it something that may be the issue if it is looping on the first find, is that you have to move the selection past the find to find the next one.

Do While bFind 'here is the endless loop
    row = row + 1
    StyleValue= currentRange.Text 'I get stuck with the first value :-(
    Rows(row).EntireRow.Insert
    Cells(row, 2).Value = StyleValue

    currentRange.SetRange currentRange.End, currentRange.End

    bFind = currentRange.Find.Execute
Loop 

If that doesn't work I can pop up a full replacement later