Option Explicit
Sub test()
'Declare variables
Dim wordDic As Object, ltrDic As Object, doubleWordDic As Object
Dim myString As String, ltr As String, tmp As String
Dim words As Variant, key As Variant, doubleWords(1 To 2, 1 To 20) As Variant, letters(1 To 2, 1 To 20) As Variant
Dim wordCount As Long, ltrCount As Long, strLen As Long, i As Integer, j As Integer, vowels As Long
myString = Application.Trim(Worksheets("Text to analyze").Range("A1").Value) 'Get the string without extra spaces
strLen = Len(myString) 'Get the length of the string
words = Split(myString, " ") 'Get the words to an array. Keep in mind that they will include neighbouring punctuation like "," or "."
wordCount = UBound(words) 'Get word count
Set wordDic = CreateObject("Scripting.Dictionary")
For i = 0 To wordCount
For j = 1 To Len(words(i))
ltr = Mid(words(i), j, 1)
If UCase(ltr) <> LCase(ltr) Then 'Get rid of punctuation
tmp = tmp & ltr
End If
Next
'Insert unique words to a dictionary with counts
If Not wordDic.Exists(LCase(tmp)) Then
wordDic.Add LCase(tmp), 1
Else
wordDic(LCase(tmp)) = wordDic(LCase(tmp)) + 1
End If
tmp = ""
Next
Set doubleWordDic = CreateObject("Scripting.Dictionary")
'Find word couples
For i = 0 To UBound(words) - 1
j = i + 1
tmp = words(i) & " " & words(j)
'Insert word couples to a dictionary with counts
If Not doubleWordDic.Exists(tmp) Then
doubleWordDic.Add tmp, 1
Else
doubleWordDic(tmp) = doubleWordDic(tmp) + 1
End If
Next
ReDim words(1 To 2, 1 To 20)
'Sort words in an array according to their count (decreasing order)
For Each key In wordDic
For i = 1 To 20
If CInt(wordDic(key)) > CInt(IIf(words(2, i) = "", 0, words(2, i))) Then
For j = 19 To i Step -1
words(1, j + 1) = words(1, j)
words(2, j + 1) = words(2, j)
Next
words(1, i) = key
words(2, i) = wordDic(key)
Exit For
End If
Next
Next
'Sort word couples in an array according to their count (decreasing order)
For Each key In doubleWordDic
For i = 1 To 20
If CInt(doubleWordDic(key)) > CInt(IIf(doubleWords(2, i) = "", 0, doubleWords(2, i))) Then
For j = 19 To i Step -1
doubleWords(1, j + 1) = doubleWords(1, j)
doubleWords(2, j + 1) = doubleWords(2, j)
Next
doubleWords(1, i) = key
doubleWords(2, i) = doubleWordDic(key)
Exit For
End If
Next
Next
Set ltrDic = CreateObject("Scripting.Dictionary")
For i = 1 To strLen
ltr = LCase(Mid(myString, i, 1)) 'Get the character
If UCase(ltr) <> ltr Then 'If character is a letter
ltrCount = ltrCount + 1 'Add character count
Select Case True
Case ltr Like "[âàäéèêëïîôûùaeiou]" 'If vowel
vowels = vowels + 1 'Add to vowels
If ltr Like "[âàäéèêëïîôûù]" Then
ltr = converstSpecialCharacter(ltr) 'If special charater
End If
Case ltr Like "[ç]" 'If special character
ltr = converstSpecialCharacter(ltr)
End Select
If ltr Like "[a-z]" Then
'Add unique letters to a dictionary with counts
If Not ltrDic.Exists(ltr) Then
ltrDic.Add ltr, 1
Else
ltrDic(ltr) = ltrDic(ltr) + 1
End If
End If
End If
Next
'Sort letters in an array according to their count (decreasing order)
For Each key In ltrDic
For i = 1 To 20
If CInt(ltrDic(key)) > CInt(IIf(letters(2, i) = "", 0, letters(2, i))) Then
For j = 19 To i Step -1
letters(1, j + 1) = letters(1, j)
letters(2, j + 1) = letters(2, j)
Next
letters(1, i) = key
letters(2, i) = ltrDic(key)
Exit For
End If
Next
Next
'Write results to Analysis sheet
With Worksheets("Linguistic Analysis")
.Range("C1").Value = ltrCount
.Range("C2").Value = vowels
.Range("C3").Value = wordCount
.Range("B6").Resize(2, 20).Value = letters
.Range("B11").Resize(2, 20).Value = words
.Range("B16").Resize(2, 20).Value = doubleWords
End With
End Sub
'Funtion that returns speacial characters as English character
Function converstSpecialCharacter(letter As String) As String
Select Case True
Case letter Like "[âàä]"
converstSpecialCharacter = "a"
Case letter Like "[éèêë]"
converstSpecialCharacter = "e"
Case letter Like "[ïî]"
converstSpecialCharacter = "i"
Case letter Like "[ô]"
converstSpecialCharacter = "o"
Case letter Like "[ûù]"
converstSpecialCharacter = "u"
Case letter Like "[ç]"
converstSpecialCharacter = "c"
End Select
End Functions
docs.google.com
