Excel Visual Basic宏以查找列中最常用的单词 [英] Excel Visual Basic Macro to find the most used words in a column

问题描述

Hello Everyone，

我正在使用这个我试图构建的宏，并且它似乎在列中的更多数据上存在问题，我试图提供它以分析单词的使用频率。

< p style ="padding-right：0px; font-size：14px; vertical-align：baseline; list-style-type：none; color：＃666666; font-family：'Segoe UI'，Helvetica，Garuda，Arial， sans-serif; line-height：21px">
我有大约10,000或更多数据，我试图筛选。代码的工作方式是突出显示列，基本上点击播放，它显示在B列和C列。

这是我正在使用的代码。我正在寻找最佳实践，以及如何避免空格，空格和任何字符。



谢谢

   Sub   Ftable  （）  
  昏暗  BigString  作为   字符串 ， 我 作为   长 ，  J  作为   长 ，  K  作为   长  
 BigString   =    ""   
  对于   每个  r  在 选择
 BigString   =   BigString  &    ""    &   r  。 价值
  下一步  r 
 BigString   =  修剪 （  BigString  ）  
 ary   =  分割 （  BigString  ，   ""  ）  
  昏暗  cl  作为 集合
  设置  cl   =    新 集合
  对于   每个  a  在  ary 
  开   错误   恢复   下一步  
 cl  。 添加 ，    CStr  （  a  ）  
  下一步  a 
 
  对于 我  =     1    要  cl  。 数
 v   =   cl  （ 我 ）  
单元格 （ 我 ，   " B"  ）。 值  =   v 
 J   =     0   
  对于   每个  a  在  ary 
  如果  a   =   v  然后  J   =   J   +     1   
  下一步  a 
 Cells  （ 我 ，   " C"  ）    =   J 
  下一步  I 
  结束    Sub   

解决方案

单向（轻微测试） ） -

 Sub SampleData（）
 Dim s 

，i As Long，c As Range每个单元格中
'10个双字母六角形单词

'随机化
每个c在范围内（"A1：A1000"）
s =""
For i = 1 to 10
s = s& Right

（" 0" Hex（Int（Rnd（）* 1023）），2） &"""
Next
c = Trim（s）
Next
End Sub

Sub testCountWords（）
Dim col As收藏，wdCnt（）As Long
Dim i As Long，tot As Long
Dim rng As Range

Set rng = Range（" A1：A1000"）
tot = CountUniqueWords（rng，col，wdCnt）

如果CountUniqueWords（rng，col，wdCnt）那么
For i = 1 to col.Count
Cells（i，4 ）="'&quo t;& col（i）
Cells（i，5）= wdCnt（i）
Next

End if

MsgBox" Total单词：" &安培; tot& vbCr& "独特的单词：" &安培; col.Count

结束子

函数CountUniqueWords（作为范围，作为集合，作为集合，作为长）wdCnt（）作为长）作为长
Dim bDupe作为布尔
Dim s As String
Dim i As Long，j As Long
Dim cnt As Long，tot As Long
Dim arr
Dim c As Range

Set col = New Collection
ReDim wdCnt（1 To 1000）
ReDim arr（0）

For each c in rng
s = Trim（c）

如果Len（s）那么
如果InStr（s，"""）那么
arr = Split（UCase（c.Text），""）
Else
ReDim arr（0）
arr（0）= s
End if

For i = 0 To UBound（arr）
If Len（arr（i））然后
tot = tot + 1

On Error Resume Next
col.Add arr（i），arr（i）

如果Err.Number那么
bDupe = True
结束如果

错误GoTo 0

如果bDupe则
bDupe = False
对于j = 1至cnt
如果UCase（col（j））= UCase（arr（i））则
wdCnt（j）= wdCnt（j）+ 1
退出
结束如果
下一个

否则
cnt = cnt + 1

如果cnt> UBound（wdCnt）然后
ReDim保留wdCnt（1到UBound（wdCnt）+ 1000）
结束如果

wdCnt（cnt）= 1
结束如果
结束如果
下一个
结束如果
下一个

如果col.Count则
ReDim保留wdCnt（1到cnt）
Else
Erase wdCnt
结束如果

CountUniqueWords = tot

结束函数

使用SampleData制作一些样本数据，然后运行testCountWords 

Edit1：CountUniqueWords适合接受Range作为参数，而不是最初发布的硬编码。

Edit2：On Error Resume Next现在只在'col.add'之前需要的地方

Hello Everyone,

I am using this macro that i am trying to build off of and it seems to have an issue on the more data in a column that i try to feed it to get an analysis on how often words are being used.

I have about 10,000 or more data that i am trying to sift through. The way the code works is that you highlight the column and basically hit play and it displays on Column B and C.

Here is the code i am working with. Im looking for best practices, and how to avoid spaces, blanks, and any characters.

Thank you

Sub Ftable()
    Dim BigString As String, I As Long, J As Long, K As Long
    BigString = ""
    For Each r In Selection
         BigString = BigString & " " & r.Value
    Next r
    BigString = Trim(BigString)
    ary = Split(BigString, " ")
    Dim cl As Collection
    Set cl = New Collection
    For Each a In ary
        On Error Resume Next
        cl.Add a, CStr(a)
    Next a

    For I = 1 To cl.Count
        v = cl(I)
        Cells(I, "B").Value = v
        J = 0
        For Each a In ary
            If a = v Then J = J + 1
        Next a
        Cells(I, "C") = J
    Next I
End Sub

解决方案

One way (lightly tested) -

Sub SampleData()
Dim s

, i As Long, c As Range ' 10 two letter Hex words in each cell ' Randomize For Each c In Range("A1:A1000") s = "" For i = 1 To 10 s = s & Right

("0" & Hex(Int(Rnd() * 1023)), 2) & " " Next c = Trim(s) Next End Sub Sub testCountWords() Dim col As Collection, wdCnt() As Long Dim i As Long, tot As Long Dim rng As Range Set rng = Range("A1:A1000") tot = CountUniqueWords(rng, col, wdCnt) If CountUniqueWords(rng, col, wdCnt) Then For i = 1 To col.Count Cells(i, 4) = "'" & col(i) Cells(i, 5) = wdCnt(i) Next End If MsgBox "Total words: " & tot & vbCr & "Unique words: " & col.Count End Sub Function CountUniqueWords(rng As Range, col As Collection, wdCnt() As Long) As Long Dim bDupe As Boolean Dim s As String Dim i As Long, j As Long Dim cnt As Long, tot As Long Dim arr Dim c As Range Set col = New Collection ReDim wdCnt(1 To 1000) ReDim arr(0) For Each c In rng s = Trim(c) If Len(s) Then If InStr(s, " ") Then arr = Split(UCase(c.Text), " ") Else ReDim arr(0) arr(0) = s End If For i = 0 To UBound(arr) If Len(arr(i)) Then tot = tot + 1 On Error Resume Next col.Add arr(i), arr(i) If Err.Number Then bDupe = True End If On Error GoTo 0 If bDupe Then bDupe = False For j = 1 To cnt If UCase(col(j)) = UCase(arr(i)) Then wdCnt(j) = wdCnt(j) + 1 Exit For End If Next Else cnt = cnt + 1 If cnt > UBound(wdCnt) Then ReDim Preserve wdCnt(1 To UBound(wdCnt) + 1000) End If wdCnt(cnt) = 1 End If End If Next End If Next If col.Count Then ReDim Preserve wdCnt(1 To cnt) Else Erase wdCnt End If CountUniqueWords = tot End Function

Make some sample data with SampleData, then run testCountWords 

Edit1: CountUniqueWords adapted to accept the Range as an argument, rather than hard-coded as originally posted.

Edit2: On Error Resume Next now only where needed before 'col.add'

这篇关于Excel Visual Basic宏以查找列中最常用的单词的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！