Народ срочно помоги пожалуйста))

[drum21]

прога ищет количество натболее часто встречающихся первых букв в столбике из имен.
нужно, шоб искала не только первые а все буквы в именах наиболее частую!

Private Sub CommandButton1_Click()
Dim k(8) As Integer, s As String, c As String, im As Integer
i = 1: s = "": im = 1:
Do While Cells(i, 1) <> "" 'делай пока есть слова
c = Left(Cells(i, 1), 1) 'Выбираем первый символ нового имени
j = InStr(1, s, c, vbTextCompare) 'Ищем его позицию в строке первых букв имен
If j = 0 Then k(Len(s) + 1) = 1: s = s + c Else k(j) = k(j) + 1:
i = i + 1 'проверка следующей буквы имени в столбце
Loop 'конец цикла
For j = 2 To Len(s)
If k(j) > k(im) Then im = j 'Корректируем индекс самой часто встречающейся буквы
Next j
Cells(1, 2) = Mid(s, im, 1) + " = " + CStr(k(im)): 'выводим максимум
End Sub

пример


даша к = 4
даша
саша
клава
света
саша
коля
петя
ксюша
карина
поля
дюша

прикреплю еще ексель там тож самое!

 

[alex77755]

если ещё актуально: Добавь цикл обработки букв в имени:

[codebox]Sub Кнопка1_Щелкнуть()

Dim k(28) As Integer, s As String, c As String, im As Integer
Dim ii
i = 1: s = "": im = 1:

Do While Cells(i, 1) <> "" 'делай пока есть слова

For ii = 1 To Len(Cells(i, 1)) 'делай пока есть буквы в слове

c = Mid(Cells(i, 1), ii, 1) 'перебираем все символы в имени

j = InStr(1, s, c, vbTextCompare) 'Ищем его позицию в строке первых букв имен

If j = 0 Then k(Len(s) + 1) = 1: s = s + c Else k(j) = k(j) + 1:

Next ii


i = i + 1 'проверка следующего имени в столбце
Loop 'конец цикла

For j = 2 To Len(s)
If k(j) > k(im) Then im = j 'Корректируем индекс самой часто встречающейся буквы
Next j
Cells(1, 2) = Mid(s, im, 1) + " = " + CStr(k(im)): 'выводим максимум

End Sub[/codebox]