Dim dFilePath As Object, OneKey

Sub main_proc()

    Dim Wb As Workbook, Sht As Worksheet, Rng As Range

    Set Wb = Application.ThisWorkbook

    Set Sht = Wb.Worksheets(1)

    Set dFilePath = CreateObject("Scripting.Dictionary")

    RecursionFolder ThisWorkbook.Path & "\"

    For Each OneKey In dFilePath.keys

        Ar = dFilePath(OneKey)

        Ar(2) = WordCount(Ar(1))

        Debug.Print Ar(2) & "  " & Ar(1)

         dFilePath(OneKey) = Ar

    Next OneKey

    With Sht

        .UsedRange.Offset(1).Clear

        Set Rng = .Range("A2")

        Set Rng = Rng.Resize(dFilePath.Count, 3)

        Rng.Value = Application.Rept(dFilePath.items, 1)

    End With

    Set Wb = Nothing

    Set Sht = Nothing

    Set Rng = Nothing

    Set dFilePath = Nothing

End Sub

Sub RecursionFolder(ByVal FolderPath As String)

    Dim Fso As Object

    Dim MainFolder As Object

    Dim OneFolder As Object

    Dim OneFile As Object

    Set Fso = CreateObject("Scripting.FileSystemObject")

    Set MainFolder = Fso.GetFolder(FolderPath)

    For Each OneFile In MainFolder.Files

        If OneFile.Name Like "*.doc*" Then

            dFilePath(dFilePath.Count + 1) = Array(OneFile.Name, OneFile.Path, 0)

        End If

    Next

    For Each OneFolder In MainFolder.SubFolders

        RecursionFolder OneFolder.Path

    Next

    Set Fso = Nothing

    Set MainFolder = Nothing

End Sub

Private Function WordCount(ByVal FilePath As String) As Long

    Dim wdApp As Object

    Dim wdDoc As Object

    On Error Resume Next

    Set wdApp = GetObject(, "Word.Application")

    If wdApp Is Nothing Then

        Set wdApp = CreateObject("Word.Application")

    End If

    On Error GoTo 0

    WordCount = 0

    On Error Resume Next

    Set wdDoc = wdApp.Documents.Open(FilePath)

    If wdDoc Is Nothing Then

        wdApp.Quit

        Set wdApp = Nothing

        On Error GoTo 0

        Exit Function

    Else

        WordCount = wdDoc.ComputeStatistics(0, False) '0为字数

        wdDoc.Close False

        wdApp.Quit

        Set wdApp = Nothing

    End If

End Function