Sub CitationFrequencyLister()
' Paul Beverley - Version 23.04.25
' Lists the different citations and their frequencies

myLightColour = wdColorGray25

includeNotes = True

notNames = "In From For Act Jan January Feb February "
notNames = notNames & " Mar March Apr April NotMay June "
notNames = notNames & " July Aug August Sept September Oct Initially "
notNames = notNames & " October Nov November Dec December Finally "
notNames = notNames & " Also As Conversely Correspondingly Consequently "
notNames = notNames & " Equally Furthermore Lastly Moreover However "
notNames = notNames & " Secondly Thirdly Similarly Additionally "

CR = vbCr
CR2 = CR & CR
myScreenOff = False

Dim myCol(4)
myCol(0) = wdYellow
myCol(1) = wdBrightGreen
myCol(2) = wdRed
myCol(3) = wdTurquoise
myCol(4) = wdGray25


myResponse = MsgBox("Is the cursor placed in the first item" _
     & CR2 & "of the references list?", vbQuestion _
     + vbYesNoCancel, "CitationFrequencyLister")
If myResponse <> vbYes Then Exit Sub

Set rng = Selection.Range.Duplicate
rng.End = ActiveDocument.Content.End
If rng.Tables.Count > 0 Then
  Beep
  myTime = Timer
  Do
  Loop Until Timer > myTime + 0.2
  Beep
  myResponse = MsgBox("WARNING: References must be at the very END." _
       & CR2 & "Move appendices to above the references.", vbQuestion _
       + vbOK, "CitationFrequencyLister")
  If myResponse <> vbYes Then Exit Sub
End If

On Error GoTo ReportIt
Application.ScreenUpdating = False

' copy references right to the end
Selection.Expand wdParagraph
Selection.Collapse wdCollapseStart
startRefs = Selection.Start
Set rngOld = ActiveDocument.Content
rngOld.Start = startRefs
rngOld.Copy
rngOld.Collapse wdCollapseStart
rngOld.Start = 0

' create new file of the text (not refs) + notes
Set mainDoc = ActiveDocument
Documents.Add
Selection.Text = rngOld.Text

' Copy footnotes and endnotes, text only
gotFoots = (mainDoc.Footnotes.Count > 0)
gotEnds = (mainDoc.Endnotes.Count > 0)
DoEvents

If gotFoots = True And includeNotes = True Then
  Selection.EndKey Unit:=wdStory
  Selection.TypeText Text:=vbCr
  Selection.Text = mainDoc.StoryRanges(wdFootnotesStory).Text
End If
If gotEnds = True And includeNotes = True Then
  Selection.EndKey Unit:=wdStory
  Selection.TypeText Text:=vbCr
  Selection.Text = mainDoc.StoryRanges(wdEndnotesStory).Text
End If
DoEvents

Debug.Print "Searching the text for possible citations"
Debug.Print "This will take quite a while..." & CR

Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ",([0-9]{4})"
  .Wrap = wdFindStop
  .Replacement.Text = ", \1"
  .Forward = True
  .MatchWildcards = True
  .MatchWholeWord = False
  .Execute Replace:=wdReplaceAll
End With

With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[a-z] \([A-Z]"
  .Wrap = wdFindStop
  .Replacement.Text = ""
  .Forward = True
  .MatchWildcards = True
  .MatchWholeWord = False
  .Execute
End With

Do While rng.Find.Found = True
  endNow = rng.End
  rng.MoveStart wdWord, -1
  rng.MoveEnd wdCharacter, -1
  rng.Select
  rng.Text = LCase(rng.Text)
  rng.MoveStart wdWord, -1
  rng.Select
  myMidWord = Left(rng, 3)
  If myMidWord = "und" Or myMidWord = "and" Then
    rng.MoveStart wdWord, -1
    rng.Text = LCase(rng.Text)
  End If
  rng.Select
  rng.Start = endNow + 2
  rng.End = endNow + 2
  rng.Find.Execute
  DoEvents
Loop

Debug.Print "Preparing the text" & CR

' Find and replace to create easy-to-search text
myList = "#ü|uu#û|qcq#~<([A-Z]{2}).|\1# in press| 2999#/| #" & _
     "~<([A-Z]).|\1#(| #)| #:| #;| #, | #" & _
     "~<([A-Z])> ([A-Z])|\1ü\2#~<([A-Z]{2})> ([A-Z])|\1ü\2#" & _
     "#.|ü#(|ü#)|ü#[|ü#]|ü#" & _
     " et alii|üetüal# et al|üetüal# & |üandü# und |üandü#-|û#" & _
     "~<de la |DeüLaü#~<De la |DeüLaü#~<De La |DeüLaü#" & _
     " e |üeü# y |üyü#~<van |Vanü#~<de |Deü#" & _
     " and |üandü#~<von |Vonü#~<van |Vanü#~<de |Deü#" & _
     "~<El |Elü#~<del |Delü#~<Del |Delü#~<la |Laü#~<La |Laü#" & _
     "~<le |Leü#~<di |Diü#~<dos |Dosü#~<la |Laü#~<le |Leü#" & _
     "~<der |Derü#üvon |üVonü#üvan |üVanü#üde |üDeü#üder |üDerü#" & _
     "üdi |üDiü#üdos |üDosü#üla |üLaü#üle |üLeü# ü| #ü | #" & _
     "~([0-9])ü|\1 #~ü([0-9])| \1#  | #"

FandR = Split(myList, "#")
Set rng = ActiveDocument.Content
For i = 1 To UBound(FandR)
  myFR = FandR(i)
  If Left(myFR, 1) <> ChrW(124) And _
       InStr(myFR, ChrW(124)) > 0 Then
    If Left(myFR, 1) = "~" Then
      myWild = True
      myFR = Mid(myFR, 2)
    Else
      myWild = False
    End If
    barpos = InStr(myFR, ChrW(124))
    myFind = Left(myFR, barpos - 1)
    myRep = Mid(myFR, barpos + 1)
    With rng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = myFind
      .Wrap = wdFindContinue
      .Forward = True
      .Replacement.Text = myRep
      .Replacement.Highlight = True
      .MatchWildcards = myWild
      .Execute Replace:=wdReplaceAll
    End With
    DoEvents
  End If
  myNmbr = UBound(FandR) - i
  If myNmbr Mod 5 = 0 Then Debug.Print "Preping " & Str(myNmbr)
Next i

Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "<[12][0-9]{3}[!0-9]"
  .Wrap = wdFindStop
  .Replacement.Text = ""
  .Forward = True
  .MatchWildcards = True
  .Execute
End With

Debug.Print CR & "Checking the years" & CR
' Find & Do to find all years
Do While rng.Find.Found = True
  myEnd = rng.End
  myYear = Replace(rng, "ü", "")
  myYear = Replace(myYear, ",", "")
  myYear = Replace(myYear, ";", "")
  myYear = Trim(myYear)
  rng.Collapse wdCollapseStart
  rng.MoveStart wdWord, -1
  myInit = Left(rng, 1)
  If UCase(myInit) <> myInit Or UCase(myInit) _
       = LCase(myInit) Then GoTo getNext
  wd1 = Trim(rng)
  rng.Collapse wdCollapseStart
  rng.MoveStart wdWord, -1
  wd2 = Trim(rng)
  myInit = Left(wd2, 1)
  gotTwo = (UCase(myInit) = myInit) And _
       (UCase(myInit) <> LCase(myInit))
' Find surname one and add to citeList1
  citeList1 = citeList1 & wd1 & " " & myYear & CR
' Find surname two and add to citeList2
  If gotTwo Then citeList2 = citeList2 & wd2 & _
       " " & wd1 & " " & myYear & CR
' Check if another date follows
  rng.Start = myEnd
  rng.End = myEnd
  Do
    rng.MoveEnd wdWord, 1
    If Len(rng) < 4 Then
      rng.Collapse wdCollapseEnd
      rng.MoveEnd wdWord, 1
    End If
    myYearNumber = Val(rng)
    If Val(rng) > 1000 Then
      myYear = Trim(rng)
      citeList1 = citeList1 & wd1 & " " & myYear & CR
      If gotTwo Then citeList2 = citeList2 & wd2 & _
           " " & wd1 & " " & myYear & CR
    End If
    rng.MoveStart wdWord, 1
    myEnd = rng.Start
    DoEvents
  Loop Until myYearNumber < 1000
getNext:
  rng.Start = myEnd
  rng.End = myEnd
  rng.Find.Execute
  myLeft = Int((ActiveDocument.Content.End - rng.Start) / 100) * 10
  myDelay = myDelay + 1
  If myDelay Mod 10 = 0 Then Debug.Print Str(myLeft)
Loop

Set rng = ActiveDocument.Content
rng.Delete
Selection.TypeText Text:=citeList1
myEnd = ActiveDocument.Content.End
Selection.TypeText Text:=citeList2
Set rng = ActiveDocument.Content
rng.Start = myEnd

' Change by F&R û to -, ü to space, uu to ü, qcq to û
myList = "#ü| #uu|ü#û|-#qcq|û# 2999| in press"

FandR = Split(myList, "#")
Set rng = ActiveDocument.Content
For i = 1 To UBound(FandR)
  myFR = FandR(i)
  If Left(myFR, 1) <> ChrW(124) And _
       InStr(myFR, ChrW(124)) > 0 Then
    barpos = InStr(myFR, ChrW(124))
    myFind = Left(myFR, barpos - 1)
    myRep = Mid(myFR, barpos + 1)
    With rng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = myFind
      .Wrap = wdFindContinue
      .Forward = True
      .Replacement.Text = myRep
      .MatchWildcards = False
      .Execute Replace:=wdReplaceAll
    End With
    DoEvents
  End If
Next i

Debug.Print CR & "Started sorting"
Set rng = ActiveDocument.Content
rng.Sort SortOrder:=wdSortOrderAscending, _
     SortFieldType:=wdSortFieldAlphanumeric
rng.InsertAfter Text:=CR

' Remove duplicates
numPars = ActiveDocument.Paragraphs.Count
myTot = 1
allText = ""
' Miss first blank lines
For j = 2 To numPars - 1
  AUnow = ActiveDocument.Paragraphs(j).Range.Text
  AUnow = Replace(AUnow, CR, "")
  AUnext = ActiveDocument.Paragraphs(j + 1).Range.Text
  AUnext = Replace(AUnext, CR, "")
  If AUnext <> AUnow Then
    allText = allText & AUnow & " . . . " & Trim(Str(myTot)) & CR
 '   Debug.Print "!!!!!!!!!!!!" & CR & allText
    myTot = 1
  Else
    myTot = myTot + 1
  End If
  DoEvents
Next j
Set rng = ActiveDocument.Content
rng.Text = allText
Beep

For j = 1 To ActiveDocument.Paragraphs.Count
  myCite = ActiveDocument.Paragraphs(j).Range.Text
  If Right(myCite, 4) = ". 1" & CR Then _
       ActiveDocument.Paragraphs(j).Range.Font.Color = myLightColour
Next j

Beep
Application.ScreenUpdating = True
Exit Sub

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