4万行数据一秒！通过文字汇总数字！高效解决方案！超实用！

lgw7758

4万行数据一秒处理完成，结果去重+可视化！

sunhewei

谢谢分享 可以的

指月山人

先收藏了再说，谢谢！

yzxfelix

这个里边是不是有dll文件呢，感觉加的格式不合理啊，颜色这个不知怎么整出来的

yzxfelix

InStr(summary, keyWord) 从 源的字符中，找出keyword ,也就是统计的这个。这个INSTR函数，是模糊函数，但也会产生雷同： 比如： '许安四川信封装订机，哪我们找： 装订机，或者找信封，都会重复取值。

所以： INstr 起到了把字段比对出来的功能，但是，不是完全精确的。用这个方法的朋友要注意奥。另外，怎么整出单元格颜色，没发现怎么来的，有哪位老师知道奥

yzxfelix

所以，这个方法，貌似统计了数据，但是正式的运用，可能正确性会受到很大的质疑。往往有错误。

yzxfelix

另外就是当：语料库  字段存在 空单元格，不连续的时候，计算结果也不正确的

yzxfelix

yzxfelix 发表于 2022-6-3 18:23
另外就是当：语料库  字段存在 空单元格，不连续的时候，计算结果也不正确的

存在空的单元格，黄色的区域，统计会中断

yzxfelix

yzxfelix 发表于 2022-6-3 18:18
InStr(summary, keyWord) 从 源的字符中，找出keyword ,也就是统计的这个。这个INSTR函数，是模糊函数，但 ...

比如：黑龙江是个字段， 里边在还有 一个 字段 “龙” ， 统计结果重复了，明显不一致哈。

yzxfelix

Option Explicit
Private shWords As Worksheet
Private shDataSource As Worksheet


Public Sub wordTotal()
   
   ' Total by keywords
   
    Dim dict As Dictionary
    Dim rng As Range
    Dim arr As Variant
    Dim clearsettings As New clsExcelSettings
   
   
    Dim t
    t = Timer
   
    clearsettings.TurnOff
   
    ' Create keywords dictionary
    Set dict = createLangauageDict
   
    ' Read data source
    Set rng = createDataSourceArr
    arr = rng
   
    ' If match then total results
    Set dict = createTotalDict(dict, arr)
   
   
    'Wirte results
    Call writeResults(dict)
   
    clearsettings.Restore
   
    MsgBox ("程序运行了" & Format(Timer - t, "0.00" & "秒"))
   
   

End Sub


    ' Create keywords dictionary
   
Private Function createLangauageDict() As Dictionary

    Dim dict As New Dictionary
    Dim rg As Range
    Dim keyWord As String
    Dim i As Long
   
    Dim cCode As clsCode
   
    Set shWords = shTotal
    Set rg = shWords.Range("A1").CurrentRegion
   
    For i = 2 To rg.Rows.Count
        keyWord = Cells(i, 1)
        
        If dict.Exists(keyWord) = True Then
            Set cCode = dict(keyWord)
        Else
            Set cCode = New clsCode
            dict.Add keyWord, cCode
        End If
        
        cCode.amount = 0
        cCode.Count = 0
            
    Next i
   
    ' Return
    Set createLangauageDict = dict
   
End Function


    ' Read data source
   
Private Function createDataSourceArr() As Range
    Dim rng As Range
   
    Set shDataSource = shData
   
    Set rng = shDataSource.Range("A1").CurrentRegion
    ' Return
    Set createDataSourceArr = rng
   
End Function
   
    ' If match then total results
   
Private Function createTotalDict(dict, arr) As Dictionary
    Dim keyWord As Variant
    Dim i As Long
    Dim amount As Double
    Dim summary As String
    Dim cCode As clsCode

   
    'Match
    For Each keyWord In dict.Keys
   
        Set cCode = dict(keyWord)
        
        For i = LBound(arr, 1) + 1 To UBound(arr, 1)
            amount = Val(arr(i, 2))
            summary = arr(i, 1)
            ' Conditions
            If InStr(summary, keyWord) <> 0 And amount <> 0 Then
                cCode.amount = cCode.amount + amount
                cCode.Count = cCode.Count + 1
            End If
        Next i
    Next
   
'    ' If item equals zero then delete
    Dim key As Variant
    For Each key In dict.Keys
        Set cCode = dict(key)
        If cCode.amount = 0 Then dict.Remove (key)
    Next
   
    ' Return
    Set createTotalDict = dict
End Function
   
    ' Wirte results
Private Sub writeResults(dict)                'dict代表字典对象
    Dim key As Variant
    Dim i As Long
    Dim cCode As clsCode
   
    shWords.Range("C1").CurrentRegion.Offset(1).ClearContents
   
    ' Write
    i = 2
    For Each key In dict.Keys
        Set cCode = dict(key)
        shWords.Cells(i, "C") = key
        shWords.Cells(i, "D") = cCode.amount
        shWords.Cells(i, "E") = cCode.Count
        i = i + 1
    Next
   
    'Sort
    Dim rg As Range
    Set rg = shWords.Range("C1:E" & 65536)
    rg.Sort Key1:=shWords.Range("D1"), Order1:=xlDescending, Header:=xlYes
   
End Sub