Counting the frequency of letters in a word - optimisation - vba

Question

This program was made with Excel Visual Basic and should count the frequenzy of the letters that appear in a word you write into the A-1 cell.
For example apple - 1x a, 1x e, 1x l, 2x p, and the rest 0x
Public Sub Test()
Dim word As String
Dim wordarr(999) As String
Dim alph(1 To 29) As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m As Integer
i = 1
j = 1
k = 1
m = 1
With ThisWorkbook.Worksheets("Tabelle1")
word = .Cells(1, 1)
'clearing the columns to rewrite it
.Columns(3).EntireColumn.Clear
.Columns(4).EntireColumn.Clear
'initializing my alphabet array
alph(1) = "a": alph(2) = "b": alph(3) = "c": alph(4) = "d": alph(5) = "e": alph(6) = "f":
alph(7) = "g": alph(8) = "h": alph(9) = "i": alph(10) = "j": alph(11) = "k": alph(12) = "l":
alph(13) = "m": alph(14) = "n": alph(15) = "o": alph(16) = "p": alph(17) = "q": alph(18) = "r":
alph(19) = "s": alph(20) = "t": alph(21) = "u": alph(22) = "v": alph(23) = "w": alph(24) = "x":
alph(25) = "y": alph(26) = "z": alph(27) = "_": alph(28) = "-": alph(29) = " "
'filling up the C column with my alphabet array
For i = 1 To 29
.Cells(i, 3) = alph(i)
Next i
'converting the string word into an array
For j = 1 To Len(word)
wordarr(j) = Mid(word, j, 1)
If j = Len(word) Then
Exit For
End If
Next j
'counting the frequency of each letter in the word and writing it into
'the column next to it
For m = 1 To 29
For k = 1 To Len(word)
If alph(m) = wordarr(k) Then
.Cells(m, 4) = .Cells(m, 4).Value + 1
End If
Next k
Next m
End With
End Sub
The program is working, but it isn't working fine i guess. Do you have any suggestions on how to optimize it without over-complicating it too much, I'm pretty new to this language. Is there also another way of initializing the array. I have tried several ways but it more often than not didn't work.
I am looking forward to seeing your suggestions.

Answer 1

here is another
i added a conversion to lower case so that uppercase characters are also counted
also added counting of "*", just as an example
Public Sub Test()
Dim word As String
Dim letter As String
Dim pointer As Integer
Dim i As Integer
With ThisWorkbook.Worksheets("Tabelle1")
word = LCase(.Cells(1, 1)) ' change text to all lower case
.Columns(3).EntireColumn.Clear ' clearing the columns to rewrite it
.Columns(4).EntireColumn.Clear
For i = 1 To 26 ' filling up the C column with my alphabet array
.Cells(i, 3) = Chr(i + 96) ' chr(97)=="a", chr(122)=="z"
Next i
.Cells(27, 3) = "_" ' oddballs
.Cells(28, 3) = "-"
.Cells(29, 3) = "<space>"
.Cells(30, 3) = "*"
For i = 1 To Len(word) ' scan text and update cells as you go
letter = Mid(word, i, 1)
' If i = Len(word) Then ' "for .. next" command already does this
' Exit For
' End If
Select Case letter
Case "a" To "z"
pointer = Asc(letter) - 96 ' asc("a")==97, asc("z")==122
Case "_"
pointer = 27
Case "-"
pointer = 28
Case " "
pointer = 29
Case "*"
pointer = 30
Case Else
GoTo skip_cell_update ' this character is not counted
End Select
.Cells(pointer, 4) = .Cells(pointer, 4).Value + 1 ' increment cell
skip_cell_update:
Next i
End With
End Sub

Answer 2

Here is soemthing short and sweet that im sure youll be able to expand upon quite easily
Private Sub THIS()
Dim Char As String, compareString As String, testString As String
Dim strCount As Long, i As Long, j As Long, y As Long, rCount As Long
Dim arr(28, 1) As String
testString = ThisWorkbook.Sheets("Sheet1").Range("a1").Value
For i = 1 To Len(testString)
Char = Mid(testString, i, 1)
For j = 1 To Len(testString)
For y = LBound(arr, 1) To UBound(arr, 1)
If Char = arr(y, 0) Then
GoTo Nexti
End If
Next y
compareString = Mid(testString, j, 1)
If Char = compareString Then
strCount = strCount + 1
End If
Next j
Debug.Print ; Char
Debug.Print ; strCount
arr(i, 0) = Char
arr(i, 1) = strCount
Nexti:
strCount = 0
Next i
End Sub