Sub WordPairAlyse()
' Paul Beverley - Version 20.01.22
' Creates a file of all the adjacent word pairs

' Ignore these words
nonWords = "a,as"

myScreenOff = True

Set FUT = ActiveDocument

At = LCase(FUT.Content.Text)

doingSeveralMacros = (InStr(FUT.Name, "zzTestFile") > 0)
If doingSeveralMacros = False Then
  myResponse = MsgBox("      WordPairAlyse" & vbCr & vbCr & _
       "Find word pairs?", vbQuestion _
       + vbYesNoCancel, "WordPairAlyse")
  If myResponse <> vbYes Then Exit Sub
End If
If myScreenOff = True Then
  Application.ScreenUpdating = False
  On Error GoTo ReportIt
End If

startTime = Timer
chs = " , . ! : ; [ ] { } ( ) / \ + "
chs = chs & ChrW(8220) & " "
chs = chs & ChrW(8221) & " "
chs = chs & ChrW(8201) & " "
chs = chs & ChrW(8222) & " "
chs = chs & ChrW(8217) & " "
chs = chs & ChrW(8216) & " "
chs = chs & ChrW(8212) & " "
chs = chs & ChrW(8722) & " "
chs = chs & vbCr & " "
chs = chs & vbTab & " "
chs = " " & chs & " "
chs = Replace(chs, "  ", " ")
chs = Left(chs, Len(chs) - 1)

chars = Split(chs, " ")
For i = 1 To UBound(chars)
  At = Replace(At, chars(i), " " & chars(i) & " ")
Next i

' Remove all non-words
nonWords = "," & nonWords & ","
nonWords = Replace(nonWords, ",,", ",")
nonWords = Left(nonWords, Len(nonWords) - 1)

wd = Split(nonWords, ",")
Set rng = ActiveDocument.Content
For i = 1 To UBound(wd)
  At = Replace(At, " " & wd(i) & " ", " ")
  DoEvents
Next i
At = Replace(At, "  ", " ")

Documents.Add
Selection.Text = " " & At

Set rng = ActiveDocument.Content
Selection.HomeKey Unit:=wdStory

Set rng = ActiveDocument.Content
At = LCase(rng.Text)
myTot = Len(At)
If Asc(At) = 32 Then
  ptr = 2
Else
  ptr = 1
End If
ptrWas = ptr
Do
  ch = Mid(At, ptr, 1)
 ' Debug.Print ch & "|"
  ptr = ptr + 1
Loop Until ch = " "

w2 = Mid(At, ptrWas, ptr - ptrWas - 1)
' Debug.Print w2 & "|"

allChkd = " "
myResult = ""
Do
  w1 = w2
  ptrWas = ptr
  Do
    ch = Mid(At, ptr, 1)
    ptr = ptr + 1
  Loop Until ch = " "
  
  w2 = Mid(At, ptrWas, ptr - ptrWas - 1)
  
  If UCase(w1) <> w1 And UCase(w2) <> w2 Then
    oneWd = w1 & w2
    chk = " " & oneWd & " "
    If InStr(allChkd, chk) = 0 Then
      ' Check it!
      If InStr(At, chk) > 0 Then
        numSingle = Len(Replace(At, chk, chk & "!")) - myTot
        chk2 = " " & w1 & " " & w2 & " "
        numPair = Len(Replace(At, chk2, chk2 & "!")) - myTot
        myResult = myResult & w1 & " " & w2 & " . . " & _
             Trim(Str(numPair)) & vbCr
        myResult = myResult & oneWd & " . . " & _
             Trim(Str(numSingle)) & vbCr & vbCr
        Debug.Print Trim(Str(Int((myTot - ptr) / 6000))) _
             & ",000  to go" & "        " & w1 & " " & w2
        StatusBar = Trim(Str(Int((myTot - ptr) / 6000))) _
             & ",000  to go" & "        " & w1 & " " & w2
      End If
      allChkd = allChkd & oneWd & " "
    End If
  End If
  DoEvents
Loop Until InStr(Mid(At, ptr), " ") = 0

Selection.WholeStory
Selection.Delete
If Len(myResult) > 0 Then
  Selection.Text = myResult
  Set rng = ActiveDocument.Content
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^p^p"
    .Replacement.Text = "zczc"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
  
    .Text = "^p"
    .Replacement.Text = ":"
    .Execute Replace:=wdReplaceAll
    
    .Text = "zczc"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
  End With
  Set rng = ActiveDocument.Content
  rng.Sort SortOrder:=wdSortOrderAscending
  With rng.Find
    .Text = "^p"
    .Replacement.Text = "^p^p"
    .Execute Replace:=wdReplaceAll
    .Text = ":"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
  End With
  
  Set rng = ActiveDocument.Content
  If Len(rng.Paragraphs(1)) < 3 Then rng.Paragraphs(1).Range.Delete
Else
  Selection.TypeText vbCr & "No word pairs found" & vbCr
End If
Selection.HomeKey Unit:=wdStory
Selection.TypeText "Word pair inconsistencies" & vbCr
ActiveDocument.Paragraphs(1).Style = _
     ActiveDocument.Styles(wdStyleHeading1)
timNow = Timer
timGone = timNow - startTime
m = Int(timGone / 60)
s = Int(timGone) - m * 60
Application.ScreenUpdating = True
If doingSeveralMacros = False Then
  Beep
  myTime = Timer
  Do
  Loop Until Timer > myTime + 0.3
  Beep
  myTime = Timer
  Do
  Loop Until Timer > myTime + 0.3
  Beep
  MsgBox "Total time:" & Str(m) & " m " & Str(s) & " s"
Else
  FUT.Activate
End If
Exit Sub

ReportIt:
Application.ScreenUpdating = True
On Error GoTo 0
Resume
End Sub