I'm very new at this and I am trying to create a VBA function which returns the most used words in a pre-defined Excel spreadsheet of over 82000 rows but cannot work out what I should to make this work. Any help is very much appreciated! I also understand how basic my knowledge of all this is ... I am very actively new and learning.
Public Sub MostCommon()
Dim MyRange As Range, MyDict As Object, MyData
Dim i As Long, j As Long, wk, x
Set MyRange = Range("G2:G81200")
Set MyDict = CreateObject("Scripting.Dictionary")
MyData = MyRange.Value
For i = 1 To UBound(MyData)
wk = Split(MyData(i, 1))
For j = 0 To UBound(wk)
MyDict.Item(wk(j)) = MyDict.Item(wk(j)) 1
Next j
Next i
i = 1
For Each x In MyDict
Cells(i, "M") = x
Cells(i, "N") = MyDict.Item(x)
i = i 1
Next x
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("N:N"), SortOn:=xlSortOnValues, Order:=xlDescending
.SetRange Range("M:N")
.Orientation = xlTopToBottom
.Apply
End With
End Sub
CodePudding user response：
I did a test: Code works if all data is okay.
However, I got the error when a cell contained a formula that resulted in an error. An error is not a string like #Value, #N/A or #DIV/0, an error is an own data type in Excel (and in VBA) and cannot be "splitted", therefore the Split raises a Type Mismatch.
You can check for an cell-value error to avoid the runtime error:
If Not IsError(MyData(i, 1)) Then
wk = Split(MyData(i, 1))
For j = 0 To UBound(wk)
MyDict.Item(wk(j)) = MyDict.Item(wk(j)) 1
Next j
End If
If you still get the same runtime error, check the value of MyData(i, 1) with the debugger.
CodePudding user response：
Most Used Words in Column
- FunThomas has probably answered your question. This is just an idea of how to improve. The least efficient part of your code is writing to the range. You can vastly improve efficiency by using the
GetDictionaryfunction. - This will return two columns, the first containing each unique word from cells of a column, and the second containing the count (number of occurrences) of each word.
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: ... most common ...
' Calls: 'RefColumn','GetRange','GetDictionary'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub MostCommon()
Const sfCellAddress As String = "G2"
Const dfCellAddress As String = "M1"
Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
Dim sfCell As Range: Set sfCell = ws.Range(sfCellAddress)
Dim scrg As Range: Set scrg = RefColumn(sfCell)
If scrg Is Nothing Then Exit Sub
Dim sData As Variant: sData = GetRange(scrg)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' A=a
Dim wk() As String
Dim r As Long
Dim n As Long
For r = 1 To UBound(sData)
If Not IsError(sData(r, 1)) Then
wk = Split(CStr(sData(r, 1)))
For n = 0 To UBound(wk)
dict(wk(n)) = dict(wk(n)) 1
Next n
End If
Next r
Erase sData
Dim dData As Variant: dData = GetDictionary(dict)
Set dict = Nothing
Dim drCount As Long: drCount = UBound(dData, 1)
Dim dfCell As Range: Set dfCell = ws.Range(dfCellAddress)
Dim drg As Range: Set drg = dfCell.Resize(drCount, UBound(dData, 2))
drg.Value = dData
Dim dcrg As Range
Set dcrg = drg.Resize(ws.Rows.Count - drg.Row - drCount 1).Offset(drCount)
dcrg.ClearContents
drg.Sort Key1:=drg.Columns(2), Order1:=xlDescending, Header:=xlNo
' To additionally sort first column ascending:
'drg.Sort Key1:=drg.Columns(2), Order1:=xlDescending, _
Key2:=drg.Columns(1), Order2:=xlAscending, Header:=xlNo
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
If rg.Rows.Count rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values from a dictionary in a 2D one-based array.
' Remarks: F, F, F - returns the keys and values in two columns.
' F, F, T - returns the values and keys in two columns.
' F, T, F - returns the keys in a column.
' F, T, T - returns the values in a column.
' T, F, F - returns the keys and values in two rows.
' T, F, T - returns the values and keys in two rows.
' T, T, F - returns the keys in a row.
' T, T, T - returns the values in a row.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetDictionary(Dictionary As Object, _
Optional ByVal Horizontal As Boolean = False, _
Optional ByVal FirstOnly As Boolean = False, _
Optional ByVal Flip As Boolean = False) _
As Variant
Const ProcName As String = "getDictionary"
On Error GoTo ClearError
If Not Dictionary Is Nothing Then
Dim NoE As Long
NoE = Dictionary.Count
If NoE > 0 Then
Dim Data As Variant
Dim Key As Variant
Dim i As Long
If Not Horizontal Then
If Not FirstOnly Then
ReDim Data(1 To NoE, 1 To 2)
If Not Flip Then
For Each Key In Dictionary.Keys
i = i 1
Data(i, 1) = Key
Data(i, 2) = Dictionary(Key)
Next Key
Else
For Each Key In Dictionary.Keys
i = i 1
Data(i, 1) = Dictionary(Key)
Data(i, 2) = Key
Next Key
End If
Else
ReDim Data(1 To NoE, 1 To 1)
If Not Flip Then
For Each Key In Dictionary.Keys
i = i 1
Data(i, 1) = Key
Next Key
Else
For Each Key In Dictionary.Keys
i = i 1
Data(i, 1) = Dictionary(Key)
Next Key
End If
End If
Else
If Not FirstOnly Then
ReDim Data(1 To 2, 1 To NoE)
If Not Flip Then
For Each Key In Dictionary.Keys
i = i 1
Data(1, i) = Key
Data(2, i) = Dictionary(Key)
Next Key
Else
For Each Key In Dictionary.Keys
i = i 1
Data(1, i) = Dictionary(Key)
Data(2, i) = Key
Next Key
End If
Else
ReDim Data(1 To 1, 1 To NoE)
If Not Flip Then
For Each Key In Dictionary.Keys
i = i 1
Data(1, i) = Key
Next Key
Else
For Each Key In Dictionary.Keys
i = i 1
Data(1, i) = Dictionary(Key)
Next Key
End If
End If
End If
GetDictionary = Data
Else
Debug.Print "'" & ProcName & "': " _
& "Dictionary is empty."
End If
Else
Debug.Print "'" & ProcName & "': " _
& "Dictionary is not defined ('Nothing')."
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function