Как подсчитать количество букв?

[Simbad]

Приветствую всех участников форума.
Подскажите, пожалуйста, как подсчитать количество английских и русских букв в документе?
Заранее спасибо тем кто собирается помочь

[Sasha_Smirnov]

Вот буквально за час-десять наваял

Sub RusLettersEngLetters() 'подсчёт букв в документе (кроме сносок, надписей, колонтитулов и рисунков)'
Dim rus As Long, eng As Long, oth As Long, i As Long

With ActiveDocument.Range.Characters
    For i = 1 To .Count
    If .Item(i) Like "[А-яЁё]" Then rus = rus + 1     'счётчик русских букв'
    If .Item(i) Like "[A-z]" Then eng = eng + 1         'счётчик нерусских букв'
    If .Item(i) Like "[!A-zА-яЁё]" Then oth = oth + 1 'счётчик прочих знаков текста документа'
    Next
End With

MsgBox "В документе «" & ActiveDocument & "»" & String(2, Chr(13)) & _
"русских букв:" & String(3, Chr(9)) & rus & Chr(13) & _
"английских букв:" & String(3, Chr(9)) & eng & Chr(13) & _
"всего русских и английских букв:" & Chr(9) & rus + eng & Chr(13) & _
"прочих символов:" & String(3, Chr(9)) & oth & Chr(13) & Chr(13) & _
"символов по статистике Word:" & Chr(9) & ActiveDocument.ComputeStatistics(wdStatisticCharactersWithSpaces)

End Sub

Вообще тема, для общего развития, что надо! Жаль, что непопулярна (как, скажем, массивы:-)).

[Aent]

Вместо Like быстрее будет работать ASC() и Select Case с интервалами
кодов. Помимо надписей текст может быть на шейпах.
Отдельный вопрос - нужно ли считать WordArt ?

[Sasha_Smirnov]

Сообщение от Aent

Вместо Like быстрее будет работать ASC() и Select Case с интервалами кодов.

Предлагаю померяться скоростями! Или хотя бы дать примерную статистику.

Сообщение от Aent

Помимо надписей текст может быть на шейпах.
Отдельный вопрос - нужно ли считать WordArt ?

Ну это ж не загадка Шамаханской царицы!
Так и сам документ можно рассмотреть как квадратную О (финскую).

[doober]

Дело было вечером,
делать было нечего ...

Результаты независимой экспертизы
В тексте порядка 900 знаков( русских и английских приблизительно поровну + прочих символов около сотни)
Вариант Sasha_Smirnov -около 30 секунд

Вариант Aent - около 6-7 секунд

[Sasha_Smirnov]

Сообщение от doober

Вариант Aent - около 6-7 секунд

Sub LettersSeekAndCountWithTimer()
Dim rus As Long, eng As Long
Dim swMilliseconds As New StopWatch: swMilliseconds.StartTimer 'вкл. таймера'
    Selection.HomeKey wdStory 'переход в начало документа'

    With Selection.Find
        .Wrap = wdFindAsk
        .MatchWildcards = True
        
        .Text = "[А-яЁё]" 'шаблон для поиска русских букв'
        .Execute
                Do While .Found
                rus = rus + 1
                .Execute
                Loop
        
     Selection.HomeKey wdStory
        .Text = "[A-z]" 'шаблон для поиска английских букв'
        .Execute
                Do While .Found
                eng = eng + 1
                .Execute
                Loop
    End With
    
    MsgBox "Подсчёт занял " & Format(swMilliseconds.EndTimer / 1000, "0.000 секунды."), vbInformation
    MsgBox "Русских букв: " & rus & "; английских букв: " & eng & ".", vbInformation
End Sub

работает на порядок* быстрее. Вот она мощь метода Find!

Используемый для хронометража класс StopWatch — в приложенном документе.
_________________________
* по основанию 10, разумеется

[Skif-F]

Сообщение от Sasha_Smirnov

работает на порядок быстрее. Вот она мощь метода Find!

Нет, мощь оказалась в стандартном линейном программировании:

Sub Letters2()
    Dim strTemp As String
    Dim ДлинаТекста As Long, i As Long
    Dim rus As Long, eng As Long
    Dim swMilliseconds As New StopWatch: swMilliseconds.StartTimer 'вкл. таймера'
    
    Selection.HomeKey Unit:=wdStory                     'Устанавливает курсор в начало текста'
    Selection.EndKey Unit:=wdStory, Extend:=wdExtend    'выделяет весь текст'
    
    strTemp = Selection.Text        'Загружает выделенный текст в переменную'
    ДлинаТекста = Len(strTemp)      'Длина текста'

    For i = 1 To ДлинаТекста
        a = Mid(strTemp, i, 1)
        If (a >= "а" And a <= "я") Or a = "ё" Or (a >= "А" And a <= "Я") Or a = "Ё" Then
            rus = rus + 1
        Else
            If (a >= "a" And a <= "z") Or (a >= "A" And a <= "Z") Then
                eng = eng + 1
            End If
        End If
    Next i

    MsgBox "Подсчёт занял " & Format(swMilliseconds.EndTimer / 1000, "0.000 секунды."), vbInformation
    MsgBox "Русских букв: " & rus & "; английских букв: " & eng & ".", vbInformation
End Sub

работает на 2 порядка быстрее. 0,015 сек против 0,402 сек
Оба варианта во вложенном файле

[Sasha_Smirnov]

Супер! Нечего добавить. (Жаль, зачинатель темы не оценил!)

[Skif-F]

Сообщение от Sasha_Smirnov

(Жаль, зачинатель темы не оценил!)

Ничего, я не в обиде. Просто я поздно нашёл этот форум

[Aent]

Ну раз начали выкусывать миллисекунды...:

Sub Letters2()
    Dim strTemp As String
    Dim ДлинаТекста As Long, i As Long
    Dim rus As Long, eng As Long
    Dim swMilliseconds As New StopWatch: swMilliseconds.StartTimer 'вкл. таймера'
    
    Selection.HomeKey Unit:=wdStory                     'Устанавливает курсор в начало текста
    Selection.EndKey Unit:=wdStory, Extend:=wdExtend    'выделяет весь текст
    
    strTemp = Selection.Text        'Загружает выделенный текст в переменную
    ДлинаТекста = Len(strTemp)      'Длина текста

    For i = 1 To ДлинаТекста
        a = Mid(strTemp, i, 1)
        If (a >= "а" And a <= "я") Or a = "ё" Or (a >= "А" And a <= "Я") Or a = "Ё" Then
            rus = rus + 1
        Else
            If (a >= "a" And a <= "z") Or (a >= "A" And a <= "Z") Then
                eng = eng + 1
            End If
        End If
    Next i

    Debug.Print "Letters2: Подсчёт занял " & Format(swMilliseconds.EndTimer / 1000, "0.000 секунды.") & vbCr & _
                "Русских букв: " & rus & "; английских букв: " & eng & "."
End Sub
Sub Letters3()
    Dim strTemp As String
    Dim ДлинаТекста As Long, i As Long
    Dim rus As Long, eng As Long
    Dim swMilliseconds As New StopWatch: swMilliseconds.StartTimer 'вкл. таймера'
        
    strTemp = ActiveDocument.Content.Text        'Загружает текст в переменную
    ДлинаТекста = Len(strTemp)      'Длина текста

    For i = 1 To ДлинаТекста
        a = Asc(Mid(strTemp, i, 1))
        Select Case a
            Case 192 To 255 'а-Я
                rus = rus + 1
            Case 184, 168   'ё,Ё
                rus = rus + 1
            Case 97 To 122, 65 To 90
                eng = eng + 1
        End Select
    Next i
    Debug.Print "Letters3: Подсчёт занял " & Format(swMilliseconds.EndTimer / 1000, "0.000 секунды.") & vbCr & _
                "Русских букв: " & rus & "; английских букв: " & eng & "."
End Sub

На приведённом выше файле:

Letters2: Подсчёт занял 0,002 секунды.
Русских букв: 726; английских букв: 34.
Letters3: Подсчёт занял 0,001 секунды.
Русских букв: 726; английских букв: 34.

В нескольких тестах результат Letters3 был меньше 1 мс
Выигрыш впрочем идёт не за счёт Select а из-за

strTemp = ActiveDocument.Content.Text