Excel: Zählen von Wörtern

Option Explicit
Sub ZaehlenVonWorten()
 ->*** in den Ranges werden die Doppelpunkte gezählt
 ->*** und in der Ergebniszelle gespeichert

  Const c_Range_Ergebnis = C6
  
  Dim f_Ranges() As String, l_Ranges_cnt As Long
  Dim Doppelpunkt_cnt As Long, s_Text As String
  Dim pos As Long, x As Long
  Dim ws As Worksheet, Zelle As Range
  
  Call ZaehlenVonWortenInit(f_Ranges())
  
  Set ws = ActiveSheet
  
  Doppelpunkt_cnt = 0
  
  For x = LBound(f_Ranges()) To UBound(f_Ranges())
    For Each Zelle In ws.Range(f_Ranges(x))
      s_Text = Zelle.Value
      pos = 0
      Do
        pos = InStr(pos + 1, s_Text, :)
        If pos <> 0 Then Doppelpunkt_cnt = Doppelpunkt_cnt + 1
      Loop While pos <> 0
    Next
  Next
  
  ws.Range(c_Range_Ergebnis).Value = Doppelpunkt_cnt
  
  Set ws = Nothing: Set Zelle = Nothing
End Sub

Private Function ZaehlenVonWortenInit(f_Ranges() As String)
  
  ReDim f_Ranges(1 To 8)
  f_Ranges(1) = D10:D20
  f_Ranges(2) = D30:D40
  f_Ranges(3) = H10:H20
  f_Ranges(4) = H30:H40
  f_Ranges(5) = L10:L20
  f_Ranges(6) = L30:L40
  f_Ranges(7) = P10:P20
  f_Ranges(8) = P30:P40
  
End Function

Option Explicit
Type myMRange_struct
  s_Range As String
  l_Spalte_von As Long
  l_Spalte_bis As Long
  l_Zeile_von As Long
  l_Zeile_bis As Long
End Type

Public f_Ranges() As myMRange_struct

Function ZaehlenVonWorten2()
 ->*** in den Ranges werden die Doppelpunkte gezählt
 ->*** und in der Ergebniszelle gespeichert

  Const c_Range_Ergebnis = C6
  
  Dim M_cnt As Long, s_Text As String, x As Long
  Dim ws As Worksheet, Zelle As Range
  
  Set ws = ActiveSheet
  
  M_cnt = 0
  
  For x = LBound(f_Ranges()) To UBound(f_Ranges())
    For Each Zelle In ws.Range(f_Ranges(x).s_Range)
      s_Text = Zelle.Value
      M_cnt = M_cnt + Mxxx_Doppelpunkt_Zaehlen(s_Text)
    Next
  Next
  
  ws.Range(c_Range_Ergebnis).Value = M_cnt
  
  Set ws = Nothing: Set Zelle = Nothing
End Function
'******************************************************
Private Function Mxxx_Doppelpunkt_Zaehlen(s_Text As String) As Long
 ->*** zaehlt die Vorkommen von Mxxx: im String
  
    Const c_MaxAnzZeichenKennung_Mxxx = 6
    
    Dim pos_M As Long, pos_x As Long, s As String
    
    Mxxx_Doppelpunkt_Zaehlen = 0
    
    pos_M = 0
    Do
      pos_M = InStr(pos_M + 1, s_Text, M)
      If pos_M <> 0 Then
        For pos_x = pos_M + 1 To Len(s_Text)
          If (pos_x - pos_M) > c_MaxAnzZeichenKennung_Mxxx Then Exit For
          s = Mid(s_Text, pos_x, 1)
          Select Case s
            Case 0 To 9,  
            Case :
              Mxxx_Doppelpunkt_Zaehlen = Mxxx_Doppelpunkt_Zaehlen + 1
              Exit For
            Case Else: Exit For
          End Select
        Next
      End If
    Loop While pos_M <> 0

End Function

'******************************************************
Public Function ZaehlenVonWortenInit2()

  Dim x As Long, r As Range, ws As Worksheet
  
  ReDim f_Ranges(1 To 8)
  f_Ranges(1).s_Range = D10:D20
  f_Ranges(2).s_Range = D30:D40
  f_Ranges(3).s_Range = H10:H20
  f_Ranges(4).s_Range = H30:H40
  f_Ranges(5).s_Range = L10:L20
  f_Ranges(6).s_Range = L30:L40
  f_Ranges(7).s_Range = P10:P20
  f_Ranges(8).s_Range = P30:P40
  
  
  Application.ScreenUpdating = False
  
  Set ws = ActiveWorkbook.Worksheets.Add
  For x = LBound(f_Ranges()) To UBound(f_Ranges())
    Set r = ws.Range(f_Ranges(x).s_Range)
    f_Ranges(x).l_Spalte_von = r.Column
    f_Ranges(x).l_Zeile_von = r.Row
    f_Ranges(x).l_Spalte_bis = r.Column + r.Columns.Count - 1
    f_Ranges(x).l_Zeile_bis = r.Row + r.Rows.Count - 1
    Set r = Nothing
  Next
  
  Application.DisplayAlerts = False
  ws.Delete
  Application.DisplayAlerts = True
  
  Application.ScreenUpdating = True
  
  Set r = Nothing: Set ws = Nothing
End Function

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
  
  Dim Zelle As Range, x As Long, b_relevant As Boolean
  
  
 ->Pruefen, ob Änderung relevant für ZaehlenVonWorten2
  b_relevant = False
  For Each Zelle In Target
    For x = LBound(f_Ranges()) To UBound(f_Ranges())
      If _
        (Zelle.Row >= f_Ranges(x).l_Zeile_von) And _
        (Zelle.Row <= f_Ranges(x).l_Zeile_bis) And _
        (Zelle.Column >= f_Ranges(x).l_Spalte_von) And _
        (Zelle.Column <= f_Ranges(x).l_Spalte_bis) Then
        b_relevant = True
        GoTo AUSWERTEN
      End If
    Next
  Next
AUSWERTEN:
  Set Zelle = Nothing
  If b_relevant Then
   ->Ereignisse abstellen, sonst Schleife
    Application.EnableEvents = False
    Call ZaehlenVonWorten2
    Application.EnableEvents = True
  End If
End Sub

Private Sub Workbook_Open()
  Call ZaehlenVonWortenInit2
End Sub