range.find searchformat doesn't find all cells with any red font

[brelin]

In the attached xlsm WhyDoesntItFindAct2035 doesn't find the red font in the Act sheet B97. Even if I remove all but the red font from that cell it still won't find it. Any ideas?

[macropod]

If you look at the captured records, you'll see they all start with something red. If I copy one of those cells to B97, the macro finds it.

[p45cal]

I tried changing to
SrchStr = "?"
being a wildcard single character and got some success but it was very unreliable and caused Excel to hang (macro appeared to be running forever) occasionally. So I gave up and resorted to checking each cell character by character.
Try this (there are now several unused variables - I'll leave you to clear that up):

Sub WhyDoesntItFindAct2035b()
'2/22/2023
'The 1st sheet "Act" contains several verses in the book of Acts that are color formatted.
'I'm trying to find all verses with at least one red letter in them.
'These are the verses with any red letters: 18:9-10 20:35 22:7-8,10,18,21 23:11 26:14-18
'It only finds 18:10 26:16-18  Why?  Is there any way to make it find the others using range.find?
Dim C As Range, WrkBk As Workbook, Ctr As Long, HitColor As Variant, StRng As String
Dim NumOccur As Long, N As Long, StartTime As Double, AdjWrd As String
Dim AC As Range, lenACary As Long, cc As Range, ACary() As Variant, chRef As String
Dim Ctrstart As Long, Ctrstop As Long, FirstAddress As String
Dim BookSht As Worksheet, RsltSht As Worksheet, ByBook As Variant
Dim NumCols As Long, M As Long
Dim SrchWrd As String
Dim SrchColor As Boolean
Dim SrchStr As String, MtchCase As Boolean
Dim cbOnlyRed As Boolean
Dim cll As Range, I

MtchCase = False
cbOnlyRed = True
If MtchCase Then
  iMtchCase = vbBinaryCompare
Else
  iMtchCase = vbTextCompare
End If
SrchColor = cbOnlyRed                            'False 'True '
NumCols = 7
lenACary = 0
ReDim ACary(NumCols, lenACary)
Set WrkBk = ActiveWorkbook
Ctrstart = WrkBk.Sheets(1).Index
Ctrstop = WrkBk.Sheets(1).Index
StRng = "B1"                                     'start range
ByBook = 2
Set RsltSht = WrkBk.Sheets("Results")
StartTime = Timer
For Ctr = Ctrstart To Ctrstop
  Set BookSht = WrkBk.Sheets(Ctr)
  BookSht.Activate
  Set cc = BookSht.Range(Range(StRng), Range(StRng).End(xlDown))


   

   For Each cll In cc.Cells
    Set C = Nothing
    For I = 1 To cll.Characters.Count
      If cll.Characters(I, 1).Font.Color = RedLetterColor Then
        Set C = cll
        Exit For
      End If
    Next I
    If Not C Is Nothing Then
      chRef = GetRef(BookSht.Cells(C.Row, 1), ByBook)
      NumOccur = 0
      Call UpdateOutputArray(ACary, chRef, lenACary, NumCols, SrchWrd, AdjWrd, NumOccur, ByBook, C)
    End If
  Next cll




Next Ctr
 RsltSht.Activate
RsltSht.Cells.ClearContents
RsltSht.Cells.ClearFormats
ACary = TransposeArray(ACary)

Set AC = RsltSht.Range(Cells(1, 1), Cells(lenACary + 1, NumCols))
AC.Value = ACary
AC.Sort AC.Columns(1), xlAscending, AC.Columns(2), , xlAscending
Call VrsFill(AC)
AC.Columns(2).ClearContents
For N = 1 To AC.Rows.Count - 1
  AC.Cells(N, 2) = N
Next N
TglWrdWrpCol
Debug.Print "done WhyDoesntItFindAct2035b  " & Format((Timer - StartTime) / 60, "##0.00") & " min.  " & Time
End Sub

It's a lot slower (more than a minute here on your data).

[macropod]

Personally, I'd be inclined to do all this in Word - even automating it from Excel as per the code below if you need the results in Excel. Makes for much simpler code, too:

Sub GetRedData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim WkSht1 As Worksheet, WkSht2 As Worksheet, r As Long, x As Long
Set WkSht1 = ThisWorkbook.Sheets("Act"): Set WkSht2 = ThisWorkbook.Sheets("Results")
Dim wdApp As New Word.Application, wdDoc As Word.Document
With wdApp
  .Visible = False
  Set wdDoc = .Documents.Add: WkSht1.UsedRange.Copy
  With wdDoc
    With .Range
      .PasteExcelTable False, False, False
      With .Find
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .Font.Color = 3618778
      End With
      Do While .Find.Execute
        r = .Cells(1).RowIndex: x = x + 1
        With WkSht2
          .Range("B" & x).Value = x: .Range("C" & x).Value = r
          .Range("D" & x).Value = WkSht1.Range("A" & r).Value
          WkSht1.Range("B" & r).Copy
          .Paste Destination:=.Range("F" & x)
        End With
        .Start = .Cells(1).Range.End + 1
      Loop
      
    End With
    .Close SaveChanges:=False
  End With
  .Quit
End With
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht1 = Nothing: Set WkSht2 = Nothing
Application.ScreenUpdating = True
End Sub