Exce VBA: выделите ячейки двумя последовательными заглавными словами

Question

Я пытаюсь увидеть, есть ли макрос, чтобы выделить ячейку, в которой два последовательных слова начинаются с заглавной буквы (т.е. Сьюзан Смит, мы пошли на пляж с Сьюзан Смит, я не могу поверить, что этот ветер )

Спасибо, М

Answer 1

Пожалуйста, попробуйте это решение.

Поместите следующее в стандартный модуль кода и запустите его с активированной рабочей таблицей, чтобы выделить ячейки последовательными заглавными словами ...

Sub ShowDblCapCells()
  Dim c&, i&, j&, t&, v, w
  Const COLOR = xlThemeColorAccent4

  v = ActiveSheet.UsedRange
  For i = 1 To UBound(v)
    For j = 1 To UBound(v, 2)
      If Len(v(i, j)) Then
        For Each w In Split(v(i, j), " ")
          t = Asc(w)
          If t > 64 And t < 91 Then
            c = c + 1
            If c = 2 Then
                Cells(i, j).Interior.ThemeColor = COLOR: Exit For
            End If
          Else
            c = 0
          End If
        Next
      End If
    Next
  Next
End Sub

---

Обновление

Пожалуйста, попробуйте эту версию. Я думаю, что это может решить вашу ошибку ...

Sub ShowDblCapCells()
  Dim c&, i&, j&, t$, v, w
  Const COLOR = xlThemeColorAccent4

  v = ActiveSheet.UsedRange
  For i = 1 To UBound(v)
    For j = 1 To UBound(v, 2)
      If Len(v(i, j)) Then
        For Each w In Split(v(i, j), " ")
          t = Left(w, 1)
          If t = UCase(t) Then
            c = c + 1
            If c = 2 Then
                Cells(i, j).Interior.ThemeColor = COLOR: Exit For
            End If
          Else
            c = 0
          End If
        Next
      End If
    Next
  Next
End Sub

---

Обновление # 2

После просмотра вашей книги, пожалуйста, используйте следующую версию ...

Sub ShowDblCapCells()
  Dim c&, i&, j&, t&, v, w
  Const COLOR = xlThemeColorAccent4

  v = ActiveSheet.UsedRange
  For i = 1 To UBound(v)
    For j = 1 To UBound(v, 2)
      If Len(v(i, j)) Then
        c = 0
        For Each w In Split(v(i, j), " ")
          t = Asc(w)
          If t > 64 And t < 91 Then
            c = c + 1
            If c = 2 Then
                Cells(i, j).Interior.ThemeColor = COLOR: Exit For
            End If
          Else
            c = 0
          End If
        Next
      End If
    Next
  Next
End Sub

---

Обновление # 3

Следующая версия работает, даже если в строках есть подстроки с несколькими пробелами ...

Sub ShowDblCapCells()
  Dim c&, i&, j&, t&, v, w
  Const COLOR = xlThemeColorAccent4

  v = ActiveSheet.UsedRange
  For i = 1 To UBound(v)
    For j = 1 To UBound(v, 2)
      If Len(v(i, j)) Then
        c = 0
        For Each w In Split(v(i, j), " ")
          If Len(w) Then
            t = Asc(w)
            If t > 64 And t < 91 Then
              c = c + 1
              If c = 2 Then
                  Cells(i, j).Interior.ThemeColor = COLOR: Exit For
              End If
            Else
              c = 0
            End If
          End If
        Next
      End If
    Next
  Next
End Sub