Hi all, this is more of a learning exercise for me rather than anything else - finding and replacing date formats in the body of the document (just body text, no fields - I have read Pauls' excellent date calculation tutorial) - this is fully functional but am pretty much using a sledgehammer
and wondering if there is a better way please?
Thanks!
Code:
Private Sub Tools_Text_Find_Date_String()
'
' 1 of 2
' find date string and add ordinal
' ie 'st', 'nd', 'rd', 'th'
'
' end result - 1st November 2000
'
Dim objPara As Paragraph
Dim strTemp As String, strText As String
On Error Resume Next
' sample text
'''2/11/2000
'''11/2/2000
'''31 May 2012
'''1 January 2000
'''3 December 2500
'''4 February 2001
'''4 July 2000
'''1 November 2000
'''November 3 2100
'''July 2 3000
'''1 June
'''June 1
'''June 2000
' will produce
'''2nd November 2000
'''11th February 2000
'''31st May 2012
'''1st January 2000
'''3rd December 2500
'''4th February 2001
'''4th July 2000
'''1st November 2000
'''3rd November 2100
'''2nd July 3000
'''1st June
'''1st June
'''June 2000
For Each objPara In ActiveDocument.Paragraphs
With objPara.Range
If objPara.Range.Words.Count = 3 Then
.MoveEnd unit:=WdUnits.wdCharacter, Count:=-1
'Debug.Print "found 3 words - " & .Text
arrtemp = Split(.Text, " ")
' will work on '1 June'
If IsNumeric(arrtemp(0)) Then
If Len(arrtemp(0)) < 4 Then
Select Case arrtemp(0)
Case 1: strText = "st"
Case 2: strText = "nd"
Case 3: strText = "rd"
Case 21: strText = "st"
Case 22: strText = "nd"
Case 23: strText = "rd"
Case 31: strText = "st"
Case Else: strText = "th"
End Select
.Text = arrtemp(0) & strText & " " & arrtemp(1)
End If
End If
' will work on 'June 1'
If IsNumeric(arrtemp(1)) Then
If Len(arrtemp(1)) < 4 Then
Select Case arrtemp(1)
Case 1: strText = "st"
Case 2: strText = "nd"
Case 3: strText = "rd"
Case 21: strText = "st"
Case 22: strText = "nd"
Case 23: strText = "rd"
Case 31: strText = "st"
Case Else: strText = "th"
End Select
.Text = arrtemp(1) & strText & " " & arrtemp(0)
End If
End If
End If
If objPara.Range.Words.Count > 3 Then
If Len(objPara.Range) > 0 Then
'.Select ' doesn't move range if selected first
.MoveEnd unit:=WdUnits.wdCharacter, Count:=-1
.Select
' test if the 4 characters are a number in year format
If IsNumeric(Right(.Text, 4)) Then
strTemp = Right(.Text, 4)
.Text = OrdinalDate(objPara.Range.Text) & " " & strTemp
ElseIf Not IsNumeric(Right(.Text, 4)) Then
.Text = OrdinalDate(objPara.Range.Text)
End If
'.Text = OrdinalDate(objPara.Range.Text) & " " & strTemp
End If
End If
End With
Next objPara
Set objPara = Nothing
' superscript the ordinals
Tools_Make_Ordinal_Suffixes_Superscript
Debug.Print Now & " - finished"
End Sub
Private Function OrdinalDate(myDate As Date)
'
' 2 of 2
' https://excel.tips.net/T002510_Adding_Ordinal_Notation_to_Dates.html
'
Dim dDate As Integer
Dim dText As String
Dim mDate As Integer
Dim mmmText As String
dDate = Day(myDate)
mDate = Month(myDate)
Select Case dDate
Case 1: dText = "st"
Case 2: dText = "nd"
Case 3: dText = "rd"
Case 21: dText = "st"
Case 22: dText = "nd"
Case 23: dText = "rd"
Case 31: dText = "st"
Case Else: dText = "th"
End Select
Select Case mDate
Case 1: mmmText = " January"
Case 2: mmmText = " February"
Case 3: mmmText = " March"
Case 4: mmmText = " April"
Case 5: mmmText = " May"
Case 6: mmmText = " June"
Case 7: mmmText = " July"
Case 8: mmmText = " August"
Case 9: mmmText = " September"
Case 10: mmmText = " October"
Case 11: mmmText = " November"
Case 12: mmmText = " December"
End Select
OrdinalDate = dDate & dText & mmmText
End Function
here's the superscript routine
Code:
Private Sub Tools_Make_Ordinal_Suffixes_Superscript()
'
' affects ALL document content - document body and tables
'
' makes any of st, nd, rd, th superscripted text when preceded by a number
'
' https://answers.microsoft.com/en-us/msoffice/forum/all/superscript-macro/57009d90-3800-4349-b4e6-67f654f55bda
'
Dim intCounter As Integer
Dim rngRange As Word.Range
Dim StartTime As Single
StartTime = Timer
intCounter = 0
Set rngRange = ActiveDocument.Range
Debug.Print "Process ordinals for superscripting"
With rngRange.Find
.Text = "([0-9]{1,2})([dhnrst]{2})"
'
' 3rd group ([!0-9a-zA-Z]) doesn't work with table cell content
' and is instead ignored, likely due to end of cell character
'.Text = "([0-9]{1,2})([dhnrst]{2})([!0-9a-zA-Z])"
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
While .Execute
Debug.Print "- processing page " & rngRange.Information(wdActiveEndPageNumber)
Do While IsNumeric(rngRange.Characters.First)
rngRange.MoveStart wdCharacter, 1
Loop
If rngRange.Font.Superscript <> True Then rngRange.Font.Superscript = True
intCounter = intCounter + 1
rngRange.Collapse wdCollapseEnd
Wend
End With
Set rngRange = Nothing
Selection.GoTo What:=wdGoToSection, Which:=wdGoToFirst
Debug.Print "Superscripted " & intCounter & " entries - time taken was: " & (Timer - StartTime) & " seconds"
End Sub