Sub Test_ReturnUniqueWordsAndCountsInSelectedRanges()
Dim x As Variant
Dim sWorksheet As String
x = ReturnUniqueWordsAndCountsInSelectedRanges(Selection, "A", "V")
MsgBox UBound(x, 2) & " unique words in selection."
'If you want to display a list of the words and counts on the 'Output' worksheet
' (which will be deleted and recreated each time the code is run then comment out
' (with a single quote) the 'GoTo End_Sub' line that follows
GoTo End_Sub
sWorksheet = "Output"
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(sWorksheet).Delete
Application.DisplayAlerts = True
On Error GoTo 0
Worksheets.Add(After:=Sheets(Sheets.count)).Name = sWorksheet 'After last
Range("A1").Resize(1, 2).Value = Array("Word", "Count")
Worksheets(sWorksheet).Range("A2").Resize(UBound(x, 2), 2).Value = Application.Transpose(x)
End_Sub:
End Sub
Function ReturnUniqueWordsAndCountsInSelectedRanges(rngInput As Range, Optional sSortOrder_ADX As String, Optional sSortField_VC As String)
'Not case sensitive
'SortOrder "D" = Descending sSortField "C" = Sort by Count
' "X" = Unsorted Anything Else = Sort by Values (Not case sensitive)
' Anything else = Ascending
Dim lX As Long, lY As Long
Dim rngSelected() As Range 'Array that contains each selected cell
Dim lSelectedCount As Long
Dim varA As Variant
Dim varOutput As Variant
Dim varK As Variant, varI As Variant
Dim varTemp1 As Variant, varTemp2 As Variant
Dim bSortOrderCheck As Boolean
Dim lSortOrder As Long
Dim lSortField As Long
Dim aryWords As Variant
Dim sCellContents As String
Dim sCellRebuild As String
Dim sOneChar As String
Select Case UCase(sSortOrder_ADX)
Case "D": lSortOrder = 2 'Descending
Case "X": lSortOrder = 3 'Unsorted
Case Else: lSortOrder = 1 'Ascending
End Select
Select Case UCase(sSortField_VC)
Case "C": lSortField = 2 'Sort by Count
Case Else: lSortField = 1 'Sort by Value
End Select
'Iterate all areas; each individual cell into 1D array
For lX = 1 To rngInput.Areas.count
For lY = 1 To rngInput.Areas(lX).Cells.count
lSelectedCount = lSelectedCount + 1
ReDim Preserve rngSelected(1 To lSelectedCount)
Set rngSelected(lSelectedCount) = rngInput.Areas(lX).Cells(lY)
Next
Next
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
'Inventory selected cells
For Each varA In rngSelected
sCellContents = varA.Value
'Replace non-alpha characters with space
For lX = 1 To Len(sCellContents)
sOneChar = Mid(sCellContents, lX, 1)
Select Case Asc(sOneChar)
Case 65 To 90, 97 To 122
sCellRebuild = sCellRebuild & sOneChar
Case Else
sCellRebuild = sCellRebuild & " "
End Select
Next
'Replace multiple spaces with single space
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\s{2,}" 'Instances of 2 or more consecutive spaces
sCellRebuild = Trim(.Replace(sCellRebuild, " "))
End With
'Add individual words to Scripting Dictionary
aryWords = Split(sCellRebuild, " ")
For lX = LBound(aryWords) To UBound(aryWords)
.Item(aryWords(lX)) = .Item(aryWords(lX)) + 1
Next
Next
'Copy Values (Keys) and Counts (Items) from Scripting Dictionary to 1D arrays
varK = .Keys
varI = .Items
'Copy both to 2D array
ReDim varOutput(1 To 2, 1 To .count)
For lX = 1 To .count
varOutput(1, lX) = varK(lX - 1)
varOutput(2, lX) = varI(lX - 1)
Next
End With
If lSortOrder < 3 Then 'A sort option was selected (1=
'Sort 2D array
For lY = LBound(varOutput, 2) To UBound(varOutput, 2) - 1
For lX = lY + 1 To UBound(varOutput, 2)
bSortOrderCheck = UCase(varOutput(lSortField, lY)) > UCase(varOutput(lSortField, lX)) 'Ascending Order Sort
If lSortOrder = 2 Then bSortOrderCheck = Not bSortOrderCheck
If bSortOrderCheck Then
varTemp1 = varOutput(1, lX)
varTemp2 = varOutput(2, lX)
varOutput(1, lX) = varOutput(1, lY)
varOutput(2, lX) = varOutput(2, lY)
varOutput(1, lY) = varTemp1
varOutput(2, lY) = varTemp2
End If
Next
Next
End If
ReturnUniqueWordsAndCountsInSelectedRanges = varOutput
'Set rngInput = Nothing 'if this is uncommented then the range in the calling routine is set to Nothing as well
End Function
