Zkusil jsem to ještě makrem. Spíše pro inspiraci, nejsou ošetřeny některé stavy.
Funkce IxDobraShoda vrátí index v poli, které se shoduje v největším počtu slov. Delší slovo má větší váhu, pokud je shod více, bere se první. Pokud není nic nalezenou, lze třetím parametrem definovat vrácenou hodnotu.
' Vrací index nelepší shody. Delší slovo má větší váhu.
Function IxDobraShoda(S as String, Pole() as Variant, Optional Default as variant) as Variant
Dim aSlova() as Variant
Dim aTexty() as Variant
Dim i as Long, j as Long
Dim PracText as String
Dim Vaha as Long
Dim Shoda as Long, MaxShoda as Long
aSlova = Slova(RemoveDiak(S))
If LBound(Pole) = UBound(Pole) Then ' Řádek
ReDim aTexty(LBound(Pole,2) to UBound(Pole,2))
i = LBound(Pole)
For j = LBound(Pole,2) to UBound(Pole,2)
aTexty(j) = Pole(i, j)
Next
Else ' Sloupec
ReDim aTexty(LBound(Pole) to UBound(Pole))
j = LBound(Pole, 2)
For i = LBound(Pole, 1) to UBound(Pole, 1)
aTexty(i) = Pole(i, j)
Next
End If
' Můžeme hledat
MaxShoda = 0
If IsMissing(Default) Then
IxDobraShoda = -1
Else
IxDobraShoda = Default
End If
For i = LBound(aTexty) to UBound(aTexty)
PracText = RemoveDiak(RemoveZnaky(aTexty(i)))
Vaha = UBound(aSlova) - LBound(aSlova)
Shoda = 0
For j = LBound(aSlova) to UBound(aSlova)
If InStr(1 , PracText , aSlova(j)) > 0 Then Shoda = Shoda + 2 ^ Vaha
Vaha = Vaha - 1
Next j
If MaxShoda < Shoda Then
IxDobraShoda = i
MaxShoda = Shoda
End If
Next i
End Function
' Setříděný seznam slov
Function Slova(S as String, Optional Pocet as Integer) as Variant
Dim aSlova(0 to 0) As Variant
Dim i as Long, j as Long, n as Long, b as Long
Dim Temp as String
' Zbavím se teček, ...
aSlova = Split(RemoveZnaky(S), " ")
b = LBound(aSlova): n = UBound(aSlova)
For i = b To n - 1 ' bubliny, předpokládám malý počet slov
For j = i + 1 To n
If Len(aSlova(i)) < Len(aSlova(j)) Then
Temp = aSlova(i)
aSlova(i) = aSlova(j)
aSlova(j) = Temp
End If
Next j
Next i
If IsMissing(Pocet) Then Pocet = 3
If n - b > (Pocet - 1) Then n = (Pocet - 1) + b
ReDim Preserve aSlova(b to n) As Variant
Slova = aSlova
End Function
Function RemoveDiak (vstup as string)
Dim i as integer
pismenasdiak = array("ě","š","č","ř","ž","ý","á","í","é","ú","ů","ä","ë","ó","ö","ü","ď","ť","ň","Ě","Š","Č","Ř","Ž","Ý","Á","Í","É","Ú","Ů","Ä","Ë","Ó","Ö","Ü","Ď","Ť","Ň")
pismenabezdiak = array("e","s","c","r","z","y","a","i","e","u","u","a","e","o","o","u","d","t","n","E","S","C","R","Z","Y","A","I","E","U","U","A","E","O","O","U","D","T","N")
For i = lbound(pismenasdiak) to ubound(pismenasdiak)
vstup = Replace(vstup, pismenasdiak(i), pismenabezdiak(i))
Next i
RemoveDiak = vstup
End Function
' Smaže zadané znaky
Function RemoveZnaky (Vstup as string, Optional Smazat as String) as String
Dim i as integer
If IsMissing(Smazat) Then Smazat = ".,?!:)("
For i = 1 to Len(Smazat)
Vstup = Replace(Vstup, Mid(Smazat, i, 1), " ")
Next i
Vstup = Trim(Vstup)
RemoveZnaky = Vstup
End Function