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

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