Sub FindSamePlace()
' Paul Beverley - Version 16.10.23
' Finds the same place in another open file

' selectCurrentWord = True
selectCurrentWord = False

' Select whole words
' wholeWordsSelect = True
wholeWordsSelect = False


' onlyLookInTheseFiles = "_PB"
onlyLookInTheseFiles = ""

notThisFile = "zzSwitchList"
notThisFile = "zzSw"
notThisFileEnd = "XX"

' alphaOrderUp = False
alphaOrderUp = True

preserveOriginalFind = False
doWholeWordSearch = False

myStep = 10
minLength = 15
myWidth = 1000
myHeight = 500

nowFind = Selection.Find.Text
Selection.Find.MatchWholeWord = False

If Selection.Start = Selection.End Then
  If selectCurrentWord = True Then
    Selection.Expand wdWord
    Do While InStr(ChrW(8217) & "' ", _
         Right(Selection.Text, 1)) > 0
      Selection.MoveEnd , -1
      DoEvents
    Loop
  Else
    hereNow = Selection.Start
    Selection.HomeKey Unit:=wdLine
    cursorPos = hereNow - Selection.Start
    Selection.MoveDown Unit:=wdLine, Count:=1, _
         Extend:=wdExtend
    repeatedSearch = (Len(Selection) > 2 * myStep)
  End If
Else
  If wholeWordsSelect = True Then
    Set rng = Selection.Range.Duplicate
    rng.Collapse wdCollapseEnd
    rng.Expand wdWord
    Do While InStr(ChrW(8217) & "' ", Right(rng.Text, 1)) > 0
      rng.MoveEnd , -1
      DoEvents
    Loop
    Selection.Collapse wdCollapseStart
    Selection.Expand wdWord
    Selection.Collapse wdCollapseStart
    rng.Start = Selection.Start
    rng.Select
  End If
End If

dotsPos = InStr(Selection, " . . . ")
If dotsPos > 0 Then
    Selection.Collapse wdCollapseStart
    Selection.MoveRight , dotsPos - 2
    Selection.Expand wdWord
    Do While InStr(" ", Right(Selection.Text, 1)) > 0
      Selection.MoveEnd , -1
      DoEvents
    Loop
End If
dotsPos = InStr(Selection, " . . ")
If dotsPos > 0 Then
  Selection.Collapse wdCollapseStart
  Selection.MoveEndUntil cset:=".", Count:=wdForward
  Selection.MoveEnd , -1
End If

mySearch = Trim(Replace(Selection, Chr(13), ""))
Selection.Collapse wdCollapseEnd

Set thisDoc = ActiveDocument
Set rng = ActiveDocument.Content
rng.End = Selection.End
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[[[[[ "
  .Wrap = wdFindContinue
  .Replacement.Text = ""
  .Forward = False
  .MatchWildcards = False
  .MatchWholeWord = False
  .Execute
End With

If rng.Find.Found Then
  rng.Expand wdParagraph
  rng.End = rng.End - 1
  tryThisName = rng
  tryThisName = Replace(tryThisName, " ]]]]]", "")
  tryThisName = Replace(tryThisName, "[[[[[ ", "")
Else
  tryThisName = ""
End If

totWnds = Application.Windows.Count

' What's this for? I dunno!
' Something to do with having multiple windows
' open on a single file?
For i = 1 To totWnds
  Set myDoc = Application.Windows(i).Document
  If myDoc.FullName = thisDoc.FullName Then
    thisFileNum = i
    myDocNum = i
    Exit For
  End If
Next i

If alphaOrderUp = True Then
  s = 1
Else
  s = -1
End If

myPtr = totWnds + myDocNum - 1
For i = 1 To totWnds - 1
  myPtr = myPtr + s
  n = myPtr Mod totWnds + 1
  Set myWnd = Application.Windows(n)
  winState = myWnd.WindowState
  Set myDoc = Application.Windows(n).Document
  endBit = Right(myDoc.Content, 10)
  doThis = (InStr(endBit, notThisFileEnd) = 0)
  thisName = myDoc.Name
  If onlyLookInTheseFiles > "" Then
    doThis = (InStr(thisName, onlyLookInTheseFiles) > 0)
  End If
  If myDoc.FullName <> thisDoc.FullName And doThis And _
      InStr(myDoc.Name, notThisFile) = 0 Then
    If thisName = tryThisName Then tryThisName = ""
    Set rng = Documents(myDoc).Content
    Debug.Print myDoc.Name
    
    
    With rng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchCase = False
      .MatchWildcards = False
      If selectCurrentWord = True And _
           doWholeWordSearch = True Then
        .MatchWholeWord = True
      Else
        .MatchWholeWord = False
      End If
      .Text = mySearch
      .Forward = True
      .Execute
    End With
    If rng.Find.Found = True Then
      myDoc.Activate
      If myWnd.WindowState = 2 Then _
           myWnd.WindowState = wdWindowStateNormal
      rng.Select
      Selection.MoveLeft , 1
      rng.Select
      If tryThisName > "" Then
        GoTo LoadFile
      Else
        GoTo myEnd
      End If
    Else
      numFoots = myDoc.Footnotes.Count
      numEnds = myDoc.Endnotes.Count
      If numFoots + numEnds > 0 Then
        If numFoots > 0 Then Set rng = _
             myDoc.StoryRanges(wdFootnotesStory)
        If numEnds > 0 Then Set rng = _
            myDoc.StoryRanges(wdEndnotesStory)
        With rng.Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .MatchCase = False
          .MatchWildcards = False
          If selectCurrentWord = True Then
            .MatchWholeWord = True
          Else
            .MatchWholeWord = False
          End If
          .Text = mySearch
          .Forward = True
          .Execute
        End With
        If rng.Find.Found = True Then
          rng.Select
          If myWnd.WindowState = 2 Then _
               myWnd.WindowState = wdWindowStateNormal
          GoTo myEnd
        End If
      End If
    End If
  End If
  myWnd.WindowState = winState
Next i

LoadFile:
' Now try to find the search text in the "[[[[[" file
On Error Resume Next
If tryThisName > "" Then
  Documents.Open tryThisName
  If Err.Number = 5174 Then
    MsgBox ("Can't find file: " & tryThisName)
    Err.Clear
  Else
    Application.Resize Width:=myWidth, Height:=myHeight
    On Error GoTo 0
    Set rng = ActiveDocument.Content
    With rng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchCase = False
      .MatchWildcards = False
      If selectCurrentWord = True Then
        .MatchWholeWord = True
      Else
        .MatchWholeWord = False
      End If
      .Text = mySearch
      .Forward = True
      .Execute
    End With
    If rng.Find.Found = True Then
      If myWnd.WindowState = 2 Then _
           myWnd.WindowState = wdWindowStateNormal
      rng.Select
      GoTo myEnd
    Else
      numFoots = myDoc.Footnotes.Count
      numEnds = myDoc.Endnotes.Count
      If numFoots + numEnds > 0 Then
        If numFoots > 0 Then Set rng = _
             ActiveDocument.StoryRanges(wdFootnotesStory)
        If numEnds > 0 Then Set rng = _
             ActiveDocument.StoryRanges(wdEndnotesStory)
        With rng.Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .MatchCase = False
          .MatchWildcards = False
          If selectCurrentWord = True Then
            .MatchWholeWord = True
          Else
            .MatchWholeWord = False
          End If
          .Text = mySearch
          .Forward = True
          .Execute
        End With
        If rng.Find.Found = True Then
          rng.Select
          If myWnd.WindowState = 2 Then _
               myWnd.WindowState = wdWindowStateNormal
          GoTo myEnd
        End If
      End If
    End If
  End If
End If

' Now try looking for a subset of the search text
If repeatedSearch = True Then
  Do
    If Len(mySearch) > 2 * cursorPos Then
      mySearch = Left(mySearch, Len(mySearch) - myStep)
    Else
      mySearch = Right(mySearch, Len(mySearch) - myStep)
      cursorPos = cursorPos - myStep
    End If
    myPtr = totWnds + myDocNum - 1
    For i = 1 To totWnds - 1
      myPtr = myPtr + s
      n = myPtr Mod totWnds + 1
      Set myWnd = Application.Windows(n)
      Set myDoc = Application.Windows(n).Document
      If myDoc.FullName <> thisDoc.FullName And _
          InStr(myDoc.Name, notThisFile & ".doc") = 0 Then
        If thisName = tryThisName Then tryThisName = ""
        myDoc.Activate
        Set rng = ActiveDocument.Content
        With rng.Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .MatchCase = False
          .MatchWildcards = False
          .MatchWholeWord = False
          .Text = mySearch
          .Forward = True
          .Execute
        End With
        If rng.Find.Found = True Then
          If myWnd.WindowState = 2 Then _
               myWnd.WindowState = wdWindowStateNormal
          rng.Select
          GoTo myEnd
        End If
      End If
    Next i
  Loop Until Len(mySearch) < minLength
End If
Beep
thisDoc.Activate

myEnd:
If rng.Find.Found = True Then myDoc.Activate
If preserveOriginalFind = True Then
  Selection.Find.Text = nowFind
     Else
  Selection.Find.Text = mySearch
End If
End Sub