[已解决]统计多个word文档中姓名出现次数方面的问题

wenwen000424

求助问题：将数据箱中的多个word文档中获得优秀的姓名、年份与次数自动进行统计，先行谢过！ 统计.rar (9.96 KB, 下载次数: 28)

2011-7-25 09:42 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

wxyqxxz2007

2011-7-25 22:15

Option Explicit
Sub yy()
    Dim dpath As String
    Dim Filename As String
    Dim v As Integer
    Dim n As String
    Dim w As Integer
    Dim i  As Long
    Dim d As String
    Dim k As Long
    Dim wdapp As Object
    Dim dic As Object
    Dim rngs As String
    Dim wddct As Object
    Set dic = CreateObject("scripting.dictionary")
    On Error Resume Next
    dpath = ThisWorkbook.Path & "\数据箱"
    Set wdapp = CreateObject("Word.Application")
    'wdapp.Visible = True
    Set wddct = CreateObject("Word.Document")
    Application.ScreenUpdating = False
    Filename = Dir(dpath & "\*.doc")
    ReDim arr(1 To 1000, 1 To 3)
    Do While Filename <> ""
        Set wddct = wdapp.Documents.Open(dpath & "\" & Filename)
        v = wddct.Paragraphs.Count
        n = Left(LTrim(wddct.Range(Start:=wddct.Paragraphs(1).Range.Start, End:=wddct.Paragraphs(1).Range.End)), 4)
        For w = 2 To v
            rngs = wddct.Range(Start:=wddct.Paragraphs(w).Range.Start, End:=wddct.Paragraphs(w).Range.End)
            For i = 0 To UBound(Split(rngs, " "))
                If Split(rngs, " ")(i) <> "" Then
                    d = d & Replace(Split(rngs, " ")(i), vbCr, "")
                    If Len(d) >= 2 Then
                        If Not dic.Exists(d) Then
                            k = k + 1
                            dic(d) = k
                            arr(dic(d), 1) = d
                        End If
                        If arr(dic(d), 2) <> "" Then arr(dic(d), 2) = "'" & arr(dic(d), 2) & ","
                        arr(dic(d), 2) = arr(dic(d), 2) & n
                        arr(dic(d), 3) = arr(dic(d), 3) + 1
                        d = ""
                    End If
                End If
            Next
        Next
        wddct.Close
        Filename = Dir()
    Loop
    Range("e2").Resize(k, 3) = arr
    Set wddct = Nothing
    wdapp.Quit
    Set wdapp = Nothing
    Set dic = Nothing
    Application.ScreenUpdating = True
End Sub

跳转到最佳答案楼层

Zipall

数据格式不统一,不好处理,2字名有的有空格,有的没有.
姓名间的空格和姓名中的空格没有区别,且有的姓名间是1个空格,有的是2个.

建议把姓名间的空格换成制表符TAB,这样才好处理.

wenwen000424

回复 Zipall 的帖子

谢谢关注，有难度期待援手。

wxyqxxz2007

Option Explicit
Sub yy()
    Dim dpath As String
    Dim Filename As String
    Dim v As Integer
    Dim n As String
    Dim w As Integer
    Dim i  As Long
    Dim d As String
    Dim k As Long
    Dim wdapp As Object
    Dim dic As Object
    Dim rngs As String
    Dim wddct As Object
    Set dic = CreateObject("scripting.dictionary")
    On Error Resume Next
    dpath = ThisWorkbook.Path & "\数据箱"
    Set wdapp = CreateObject("Word.Application")
    'wdapp.Visible = True
    Set wddct = CreateObject("Word.Document")
    Application.ScreenUpdating = False
    Filename = Dir(dpath & "\*.doc")
    ReDim arr(1 To 1000, 1 To 3)
    Do While Filename <> ""
        Set wddct = wdapp.Documents.Open(dpath & "\" & Filename)
        v = wddct.Paragraphs.Count
        n = Left(LTrim(wddct.Range(Start:=wddct.Paragraphs(1).Range.Start, End:=wddct.Paragraphs(1).Range.End)), 4)
        For w = 2 To v
            rngs = wddct.Range(Start:=wddct.Paragraphs(w).Range.Start, End:=wddct.Paragraphs(w).Range.End)
            For i = 0 To UBound(Split(rngs, " "))
                If Split(rngs, " ")(i) <> "" Then
                    d = d & Replace(Split(rngs, " ")(i), vbCr, "")
                    If Len(d) >= 2 Then
                        If Not dic.Exists(d) Then
                            k = k + 1
                            dic(d) = k
                            arr(dic(d), 1) = d
                        End If
                        If arr(dic(d), 2) <> "" Then arr(dic(d), 2) = "'" & arr(dic(d), 2) & ","
                        arr(dic(d), 2) = arr(dic(d), 2) & n
                        arr(dic(d), 3) = arr(dic(d), 3) + 1
                        d = ""
                    End If
                End If
            Next
        Next
        wddct.Close
        Filename = Dir()
    Loop
    Range("e2").Resize(k, 3) = arr
    Set wddct = Nothing
    wdapp.Quit
    Set wdapp = Nothing
    Set dic = Nothing
    Application.ScreenUpdating = True
End Sub

wenwen000424

回复 wxyqxxz2007 的帖子

谢谢office2007 !