Sub ListOfFound()
' Paul Beverley - Version 03.04.25
' Creates a list of paragraphs containing specific word(s)

' Sets zoom size for new list (use 0 if you don't want it)
myZoom = 200
' myZoom = 0

wordsForSearchByChapter = ",Genesis 1,Matthew 1,Chapter"
chapterStyle = "Heading 2"

' listFiles output is not spaced.
listFiles = ",Macro_Menu,BirdList,"

' Warning for large number of finds
largeNumberPrompt = 25

doUnderline = True
doHighlight = False
myColour1 = wdBrightGreen
myColour2 = wdYellow
doColour = True
myFontColour1 = wdColorBlue
myFontColour2 = wdColorRed

Set myDoc = ActiveDocument
Set rng = ActiveDocument.Content
rng.End = rng.start + 200

CR = vbCr: CR2 = CR & CR
inChapters = False: inMultiFile = False: inMacroMenu = False

thisArray = Split(Trim(wordsForSearchByChapter), ",")
For i = 1 To UBound(thisArray)
  If InStr(rng, thisArray(i)) > 0 And thisArray(i) > "" Then
    inChapters = True
    Exit For
  End If
Next i

' Ignore this; it's for one of Paul's personal files
If InStr(myDoc.Name, "ttttttt") > 0 Then
  inChapters = True
  chapterStyle = "Heading 1"
End If

' For searching TheMacrosAll
If InStr(myDoc.Name, "TheMacrosAll") > 0 Then
  inMacros = True
End If

If InStr(rng, "[[[[[") > 0 Then inMultiFile = True
docName = Replace(myDoc.Name, ".docx", "")
docName = Replace(docName, ".doc", "")
If docName = "Macro_Menu" Then inMacroMenu = True
inList = InStr(listFiles, "," & docName) > 0

Set rng = Selection.Range.Duplicate
If rng.start = rng.End Then
  rng.Expand wdParagraph
  rng.MoveEnd , -1
  myTemp = Right(rng, 2)
  gotCodes = InStr(myTemp, ">") + InStr(myTemp, "!") + _
       InStr(myTemp, "#") + InStr(myTemp, """") + InStr(rng, ChrW(8221))
  If rng.Words.count > 2 And gotCodes = 0 Then
    Set rng = Selection.Range.Duplicate
    rng.Expand wdWord
    Do While InStr(ChrW(8217) & "' ", Right(rng.Text, 1)) > 0
      rng.MoveEnd , -1
      DoEvents
    Loop
  End If
Else
  endNow = rng.End
  rng.Expand wdWord
  startNow = rng.start
  rng.End = endNow
  rng.Expand wdWord
  Do While InStr(ChrW(8217) & "' ", Right(rng.Text, 1)) > 0
    rng.MoveEnd , -1
    DoEvents
  Loop
  rng.start = startNow
End If
myText = rng.Text

numSpaces = Len(myText) - Len(Replace(myText, " ", ""))
If numSpaces > 1 Then
  myText = InputBox("Search first + last word? ", "ListOfFound", _
       Trim(myText))
Else
  myText = InputBox("Search for: ", "ListOfFound", _
       Trim(myText))
End If
If myText = "" Then Beep: Exit Sub

' Search for whole text string
numSpaces = Len(myText) - Len(Replace(myText, " ", ""))

If InStr(Right(myText, 3), """") + InStr(Right(myText, 3), _
     ChrW(8221)) > 0 Then
  ' numSpaces = 0 forces a single-string search
  numSpaces = 0
  myText = Replace(myText, """", "")
  myText = Replace(myText, ChrW(8221), "")
  quotedText = True
Else
  quotedText = False
End If

' Case sensitivity required?
doCase = False
doWholeWord = False
If InStr(Right(myText, 3), "#") > 0 Then
  doCase = True
  myText = Replace(myText, "#", "")
End If

' Search whole words only?
If InStr(Right(myText, 3), ">") > 0 Then
  doWholeWord = True
  myText = Replace(myText, ">", "")
End If

' Is this a list?
If InStr(Right(myText, 3), "!") > 0 Then
  inList = True
  myText = Replace(myText, "!", "")
End If

Select Case numSpaces
  Case 0
    myText1 = myText
    myText2 = ""
  Case 1
    spPos = InStr(myText, " ")
    myText1 = Left(myText, spPos - 1)
    spPos = InStrRev(myText, " ")
    myText2 = Trim(Mid(myText, spPos))
  Case Else
    numbs = "0123456789"
    For i = 1 To Len(myText)
      ch = Mid(myText, i, 1)
      If LCase(ch) = UCase(ch) Then Exit For
    Next i
    myText1 = Left(myText, i - 1)
    For i = 1 To Len(myText)
      ch = Left(Right(myText, i), 1)
      If LCase(ch) = UCase(ch) And InStr(numbs, ch) = 0 Then Exit For
    Next i
    myText2 = Right(myText, i - 1)
End Select

If Right(myText, 1) = """" Or Right(myText, 1) = ChrW(8221) Then
  myText1 = Replace(myText, """", "")
  myText1 = Replace(myText, ChrW(8221), "")
  myText2 = ""
End If

Set rng = myDoc.Content
tst = rng.Text
If doCase = False Then
  tst = LCase(tst)
  myText1 = LCase(myText1)
  myText2 = LCase(myText2)
End If
numFinds1 = Len(tst) - Len(Replace(tst, myText1, Mid(myText1, 2)))

If myText2 > "" Then
  numFinds2 = Len(tst) - Len(Replace(tst, myText2, Mid(myText2, 2)))
  If numFinds1 / numFinds2 > 1.5 Then
    ' Switch 1 and 2 around
    myTemp = myText2
    myText2 = myText1
    myText1 = myTemp
    numTemp = numFinds1
    numFinds1 = numFinds2
    numFinds2 = numTemp
  End If
Else
  numFinds2 = 0
End If
myTarget = myText1
myLimits = ""
If myText2 > "" Then myTarget = myTarget & " and " & _
     myText2
If quotedText = True Then myTarget = ChrW(8220) & _
     myTarget & ChrW(8221)
If doWholeWord Then myLimits = myLimits & " + whole word"
If doCase Then myLimits = myLimits & " + case sensitive"
myTarget = myTarget & myLimits

If numFinds1 > largeNumberPrompt Or numFinds2 > largeNumberPrompt Then
  myPrompt = myText1 & ": " & Str(numFinds1)
  If numFinds2 > 0 Then myPrompt = myPrompt _
       & CR & myText2 & ": " & Str(numFinds2)
  If myLimits > "" Then myPrompt = myPrompt & _
       CR2 & Trim(myLimits)
  myPrompt = myPrompt & CR2 & "Continue?"
  myResponse = MsgBox(myPrompt, vbQuestion + vbYesNo, "ListOfFound")
  If myResponse <> vbYes Then Exit Sub
End If

t = Timer
Set newDoc = Documents.Add
ActiveDocument.Windows(1).WindowState = wdWindowStateMaximize
If myZoom > 0 Then Application.ActiveWindow.View.Zoom.Percentage _
     = myZoom

myDo = "TEF"
If myDoc.Footnotes.count = 0 Then myDo = Replace(myDo, "F", "")
If myDoc.Endnotes.count = 0 Then myDo = Replace(myDo, "E", "")

myCount = 0
okBooks = "1K,2K,1C,2C,1S,2S,1T,2T,1J,2J,3J,1P,2P"
For myRun = 1 To Len(myDo)
  doIt = Mid(myDo, myRun, 1)
  Select Case doIt
    Case "T": Set rng = myDoc.Content
      If inMacroMenu Then
        startPos = InStr(rng, "Bookmarks") + 85
        rng.start = startPos
      End If
    Case "E": Set rng = myDoc.StoryRanges(wdEndnotesStory)
      Selection.InsertAfter Text:=CR & "Endnotes" & CR
      Selection.Range.Font.Bold = True
      Selection.Range.Collapse wdCollapseEnd
    Case "F": Set rng = myDoc.StoryRanges(wdFootnotesStory)
      Selection.InsertAfter Text:=CR & "Footnotes" & CR
      Selection.Range.Font.Bold = True
      Selection.Range.Collapse wdCollapseEnd
  End Select
  
  With rng.Find
    .Text = myText1
    .Wrap = wdFindStop
    .Replacement.Text = ""
    .Forward = True
    .MatchCase = doCase
    .MatchWildcards = False
    .MatchWholeWord = doWholeWord
    .Execute
  End With
  
  chpHeadingNow = ""
  Do While rng.Find.found = True
    rng.Expand wdParagraph
    foundText = rng.Text
    foundText = Replace(foundText, ">", "")
    foundText = Replace(foundText, "-", " ")
    foundText = Replace(foundText, CR, "")
    If doCase = False Then foundText = LCase(foundText)
    If myText2 > "" Then
      gotOne = False
      If doWholeWord = True Then
        For Each wd In rng.Words
          wdText = Trim(wd)
          wdText = Replace(wdText, ChrW(8217), "")
          If doCase = False Then wdText = LCase(wdText)
          If wdText = myText2 Then gotOne = True: Exit For
        Next wd
      Else
        If InStr(foundText, myText2) > 0 Or numSpaces = 0 _
             Then gotOne = True
      End If
    Else
      gotOne = True
    End If
    If doIt = "T" And rng.start = 0 Then gotOne = False
    If gotOne = True Then
      myCount = myCount + 1
      If myRun > 1 Then rng.MoveStart , 2
      
      If inChapters Then
        Set qt = rng.Duplicate
        qt.start = 0
        With qt.Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Text = ""
          .Style = chapterStyle
          .Wrap = wdFindStop
          .Forward = False
          .Replacement.Text = ""
          .MatchWildcards = False
          .Execute
          DoEvents
        End With
        chpHeading = qt
      End If
       If inMacros Then
        Set qt = rng.Duplicate
        qt.start = 0
        With qt.Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Text = "^pSub"
          .Wrap = wdFindStop
          .Forward = False
          .Replacement.Text = ""
          .MatchWildcards = False
          .Execute
          DoEvents
        End With
        qt.MoveStart , 1
        qt.Expand wdParagraph
        qt.MoveEnd , -1
        chpHeading = qt
      End If
     
      If inMultiFile Then
        Set qt = rng.Duplicate
        qt.start = 0
        With qt.Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Text = "[[[[["
          .Wrap = wdFindContinue
          .Forward = False
          .Replacement.Text = ""
          .MatchWildcards = False
          .Execute
          DoEvents
        End With
        qt.Expand wdParagraph
        chpHeading = Mid(qt, 7)
        docPos = InStr(chpHeading, ".doc")
        chpHeading = Left(chpHeading, docPos - 1)
      End If
      Selection.EndKey Unit:=wdStory
      Selection.FormattedText = rng.FormattedText
      If inChapters And chpHeading <> chpHeadingNow Then
        Selection.InsertBefore Text:=CR & chpHeading
        Selection.MoveStart , 1
        Selection.Font.Bold = True
        Selection.EndKey Unit:=wdStory
        chpHeadingNow = chpHeading
      End If
      If inMultiFile And chpHeading <> chpHeadingNow Then
        Selection.InsertBefore Text:=CR2 & chpHeading & CR
        Selection.MoveStart , 1
        Selection.MoveEnd , -1
        Selection.Font.Bold = True
        Selection.EndKey Unit:=wdStory
        Selection.MoveStart , -1
        If Selection = CR Then Selection.Delete
        chpHeadingNow = chpHeading
      End If
      If inList = False And inChapters = False Then Selection.TypeText Text:=CR
    End If
    rng.Collapse wdCollapseEnd
    rng.Find.Execute
    DoEvents
  Loop
  Selection.EndKey Unit:=wdStory
Next myRun
oldColour = Options.DefaultHighlightColorIndex
If doHighlight = True Then _
     Options.DefaultHighlightColorIndex = myColour1

Set rng = newDoc.Content
If Not inMacroMenu Then
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = myText1
    .Wrap = wdFindContinue
    .Forward = True
    .Replacement.Text = ""
    If doHighlight = True Then _
         .Replacement.Highlight = doHighlight
    .Replacement.Font.Underline = doUnderline
    If doColour = True Then _
         .Replacement.Font.Color = myFontColour1
    .MatchWildcards = False
    .MatchWholeWord = doWholeWord
    .MatchCase = doCase
    .Execute Replace:=wdReplaceAll
    DoEvents
    If myText2 > "" Then
      If doHighlight = True Then _
        Options.DefaultHighlightColorIndex = myColour2
      If doColour = True Then _
           .Replacement.Font.Color = myFontColour2
      .Text = myText2
      .Execute Replace:=wdReplaceAll
    End If
    
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^2"
    .Replacement.Text = ""
    .Execute Replace:=wdReplaceAll
    .Text = ChrW(7)
    .Execute Replace:=wdReplaceAll
  End With
  Options.DefaultHighlightColorIndex = oldColour
End If

resultsText = rng.Text
If doCase = False Then resultsText = LCase(resultsText)
numFinds = Len(resultsText) - Len(Replace(resultsText, myText1, Mid(myText1, 2)))

Set rng = ActiveDocument.Content
enPos = InStr(rng, "Endnotes" & CR2 & "Foot")
If enPos > 0 Then
  rng.start = enPos - 1
  rng.End = rng.start + 10
  rng.Delete
End If

' If no finds in any notes
Set rng = ActiveDocument.Content
fnPos = InStrRev(rng, CR & "Footnotes" & CR2)
If fnPos > 0 And rng.End - fnPos < 12 Then
  rng.start = fnPos
  rng.Delete
End If

' If no finds in any notes
fnPos = InStr(rng, "Footnotes" & CR2 & CR)
If fnPos > 0 Then
  rng.start = fnPos - 1
  rng.End = rng.start + 11
  rng.Select
  rng.Delete
End If

Set rng = ActiveDocument.Content
enPos = InStr(rng, "Endnotes" & CR2 & CR)
If enPos > 0 Then
  rng.start = enPos - 1
  rng.End = rng.start + 10
  rng.Select
  rng.Delete
End If


If numFinds = 0 Then
  Beep
  myPrompt = "Sorry, no finds!" & CR2
  If doCase = True Then myPrompt = myPrompt & _
       "Well, you did ask for a case-sensitive search." & CR2
  If doWholeWord = True Then myPrompt = myPrompt & _
       "Well, you did ask for a whole-word search." & CR2
  myPrompt = myPrompt & myTarget
  MsgBox myPrompt
  newDoc.Close SaveChanges:=False
  Exit Sub
End If

Selection.HomeKey Unit:=wdStory
Selection.TypeText Text:=myTarget & CR2
Selection.TypeText Text:="Occurs: " & Str(numFinds) & CR
Selection.TypeText Text:="(In: " & Str(myCount) & " paragraphs)" & CR2
Selection.start = 0
Selection.Range.HighlightColorIndex = wdNoHighlight
Selection.Range.Font.Color = wdColorAutomatic
Selection.Range.Font.Underline = False
Selection.Collapse wdCollapseStart
Set rng = ActiveDocument.Content
With rng.ParagraphFormat
  .LineSpacingRule = wdLineSpaceSingle
  .SpaceBefore = 0
  .SpaceAfter = 0
End With
If myResponse = vbYes And Timer - t > 30 Then
  Beep
  myTime = Timer
  Do
  Loop Until Timer > myTime + 0.2
  Beep
End If
End Sub