Мне нужен алгоритм, который подсчитывает количество слов в столбце M, которые начинаются с букв "A" и "A" в Excel VBA

Question

Здесь у меня есть код, который подсчитывает только количество слов, и я не знаю, что делать, чтобы он подсчитывал слова, начинающиеся с буквы «A» и «a» в столбце M

Sub CountWords()
    Dim xRg As Range
    Dim xRgEach As Range
    Dim xAddress As String       
    Dim xRgVal As String
    Dim xRgNum As Long
    Dim xNum As Long

    On Error Resume Next
    xAddress = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Introduceti diapazonul:", "Selectare", xAddress, , , , , 8)

    If xRg Is Nothing Then Exit Sub

    Application.ScreenUpdating = False

    If Application.WorksheetFunction.CountBlank(xRg) = xRg.Count Then
        MsgBox "Numarul de cuvinte este: 0", vbInformation, ""
        Exit Sub
    End If

    For Each xRgEach In xRg
        xRgVal = xRgEach.Value
        xRgVal = Application.WorksheetFunction.Trim(xRgVal)
        If xRgEach.Value <> "" Then
            xNum = Len(xRgVal) - Len(Replace(xRgVal, " ", "")) + 1
            xRgNum = xRgNum + xNum
        End If
    Next xRgEach

    MsgBox "Numarul de cuvinte: " & Format(xRgNum, "#,##0"), vbOKOnly, "Raspuns"

    Application.ScreenUpdating = True

End Sub

Answer 1

Предполагая, что каждая ячейка содержит одиночное слово, используйте:

Sub ACount()
    Dim i As Long, N As Long, Kount As Long
    Dim ch As String
    Kount = 0
    N = Cells(Rows.Count, "M").End(xlUp).Row

    For i = 1 To N
        ch = Left(Cells(i, "M").Value, 1)
        If ch = "a" Or ch = "A" Then Kount = Kount + 1
    Next i
    MsgBox Kount
End Sub

РЕДАКТИРОВАТЬ # 1 :

Если ячейки могут содержать более одного слова (, разделенных пробелами ), использование:

Sub ACount()
    Dim i As Long, N As Long, Kount As Long
    Dim ch As String
    Kount = 0
    N = Cells(Rows.Count, "M").End(xlUp).Row

    For i = 1 To N
        arr = Split(Cells(i, "M").Value, " ")
        For Each A In arr
            ch = Left(A, 1)
            If ch = "a" Or ch = "A" Then Kount = Kount + 1
        Next A
    Next i
    MsgBox Kount
End Sub

Answer 2

Альтернатива через массивы, включая отображение списка найденных слов

Может быть полезно включить список всех допустимых слов в требуемый результат подсчета.

Просто чтобы продемонстрировать подход, аналогичный Гэри, но с использованием массивов вместо диапазона l oop, я сжал основную процедуру до трех шагов, используя функцию справки для шага [1]:

• [1] получить данные и предоставить достаточный массив wrds, вызвав функцию справки getData()
• [2] подсчитать и собрать действительные слова в al oop через все слова,
• [3] количество отображений cnt (или: UBound(wrds) плюс список допустимых слов (массив из 1-мерного числа на основе ►1 wrds)

Кроме того, можно анализировать как отдельные слова, так и группы слов, разделенные пробелами.

Sub ACount2()
    Const SEARCHLETTER As String = "a"                  ' << change to any wanted search letter
    '[1] get data and provide for sufficient wrds array
    Dim allWrds, wrds: allWrds = getData(Sheet1, wrds)  ' << change Sheet1 to your sheet's Code(Name)

    '[2] count & collect valid words
    Dim i As Long, letter As String, cnt As Long
    For i = LBound(allWrds) To UBound(allWrds)           ' loop through original words
        letter = LCase(Left(allWrds(i), 1))              ' compare with search letter (lower case)
        If letter = SEARCHLETTER Then cnt = cnt + 1: wrds(cnt) = allWrds(i)
    Next i
    ReDim Preserve wrds(1 To cnt)

    '[3] display count plus list of valid words
    MsgBox cnt & " words starting with {A|a}:" & _
           vbNewLine & vbNewLine & _
           Join(wrds, ", "), vbInformation
End Sub

Справочная функция getData(), вызываемая вышеуказанной процедурой

Function getData(sht As Worksheet, wrds, Optional ByVal col = "M", Optional ByVal StartRow As Long = 2)
'Purpose: get column data of a given worksheet and return to a "flat" array; provide for a sufficient wrds array
    'a) get 2-dim data (starting in cell M2 by default) and transpose to 1-dim "flat" array
    Dim lastRow As Long: lastRow = sht.Cells(sht.Rows.Count, col).End(xlUp).Row
    Dim data: data = Split(Join(Application.Transpose(sht.Range(col & StartRow & ":" & col & lastRow)), " "), " ")
    'b) provide for maximum elements in found words in calling procedure (implicit ByRef!)
    ReDim wrds(1 To UBound(data))
    'c) return 1-based "flat" 1-dim data array
    getData = data
End Function