|
楼主 |
发表于 2018-4-26 17:17
|
显示全部楼层
Private Sub CommandButton1_Click()
Range("a2:b99999").ClearContents
Dim arr(), brr(), crr(), dic, dic2, k As Long
Set dic = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
On Error Resume Next
arr = Range("d1:d" & [d65535].End(3).Row)
ReDim brr(1 To [d65535].End(3).Row, 1 To 1)
For i = 1 To UBound(arr)
For j = 1 To Len(arr(i, 1))
Str2 = Mid(arr(i, 1), j, 1)
If (Asc(Str2) < 0 And Asc(Str2) > -22000) Or Asc(Str2) < -24300 Then
brr(i, 1) = brr(i, 1) & Mid(arr(i, 1), j, 1)
Else
If Right(brr(i, 1), 1) <> " " Then brr(i, 1) = brr(i, 1) & " "
End If
Next j
Next i
ReDim crr(1 To 100000, 1 To 2)
k = 1
lxzf = [c3]
cp = [c5]
For i = 1 To UBound(brr)
ltws = Split(brr(i, 1), " ")
For s = 0 To UBound(ltws)
If Len(ltws(s)) < lxzf Then GoTo haha
For j = 1 To Len(ltws(s)) - lxzf + 1
str3 = Mid(ltws(s), j, lxzf) '连续字符=
dic(str3) = dic(str3) + 1
If dic(str3) >= cp Then '词频>=
If Not dic2.exists(str3) Then
dic2(str3) = k
crr(k, 1) = str3
crr(k, 2) = dic(str3)
k = k + 1
Else
crr(dic2(str3), 2) = dic(str3)
End If
End If
Next j
haha:
Next s
Next i
Range("a2").Resize(k - 1, 2) = crr
End Sub |
评分
-
1
查看全部评分
-
|