我對此很陌生，我正在嘗試創建一個 VBA 函式，該函式在超過 82000 行的預定義 Excel 電子表格中回傳最常用的單詞，但無法弄清楚我應該如何完成這項作業。很感謝任何形式的幫助！我也明白我對這一切的了解是多么的基礎......我非常積極地學習新知識。
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
uj5u.com熱心網友回復：
我做了一個測驗：如果所有資料都正常，代碼就可以作業。
但是，當單元格包含導致錯誤的公式時，我收到了錯誤訊息。錯誤不是像#Value,#N/A或那樣的字串，#DIV/0錯誤是 Excel（和 VBA）中自己的資料型別，不能“拆分”，因此Split會引發型別不匹配。
您可以檢查單元格值錯誤以避免運行時錯誤：
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
如果您仍然遇到相同的運行時錯誤，請MyData(i, 1)使用除錯器檢查 的值。
uj5u.com熱心網友回復：
列中最常用的詞
- FunThomas 可能已經回答了您的問題。這只是一個如何改進的想法。代碼中效率最低的部分是寫入范圍。使用該
GetDictionary功能可以大大提高效率。 - 以下解決方案將回傳兩列，第一列包含來自一列單元格的每個唯一單詞，第二列包含每個單詞的計數（出現次數）。
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: ... most common ...
' Calls: 'RefColumn','GetRange','DictArrayCountNoErrors','GetDictionary'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub MostCommon()
Const sfCellAddress As String = "G2"
Const dfCellAddress As String = "M1"
Const dcCount As Long = 2 ' keys and items (count)
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 sKey As Variant
Dim r As Long
For r = 1 To UBound(sData)
sKey = sData(r, 1)
If Not IsError(sKey) Then
wk = Split(CStr(sKey))
DictArrayCountNoErrors dict, wk
End If
Next r
Dim drCount As Long: drCount = dict.Count
If drCount = 0 Then Exit Sub
Erase sData
Dim dData As Variant: dData = GetDictionary(dict)
Set dict = Nothing
Dim dfCell As Range: Set dfCell = ws.Range(dfCellAddress)
Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
drg.Value = dData
Erase 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: Adds the values of an array to the keys of an existing
' dictionary and updates the count in the dictionary's items.
' Remarks: It is assumed that there are no error values, while blanks
' are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictArrayCountNoErrors( _
ByRef dict As Object, _
ByVal Arr As Variant)
Dim Key As Variant, n As Long
For n = LBound(Arr) To UBound(Arr)
Key = Arr(n)
If Len(CStr(Key)) > 0 Then
dict(Key) = dict(Key) 1
End If
Next n
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values from a dictionary in a 2D one-based array.
' Remarks: F, F, F - returns the keys and items in two columns.
' F, F, T - returns the items and keys in two columns.
' F, T, F - returns the keys in a column.
' F, T, T - returns the items in a column.
' T, F, F - returns the keys and items in two rows.
' T, F, T - returns the items and keys in two rows.
' T, T, F - returns the keys in a row.
' T, T, T - returns the items 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
轉載請註明出處，本文鏈接：https://www.uj5u.com/qiye/392495.html
標籤：擅长 vba excel-公式 运行时错误 类型不匹配
上一篇：如何在VBA中附加帶有日期的檔案