20171023xlVBA递归统计WORD字数

 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