Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 05-13-2021, 08:13 PM
LQuinn LQuinn is offline find/replace date format improvement? Windows 10 find/replace date format improvement? Office 2019
Novice
find/replace date format improvement?
 
Join Date: Jan 2021
Location: Western Australia
Posts: 20
LQuinn is on a distinguished road
Default find/replace date format improvement?

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
Reply With Quote
  #2  
Old 05-14-2021, 06:54 AM
macropod's Avatar
macropod macropod is offline find/replace date format improvement? Windows 10 find/replace date format improvement? Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

For example:
Code:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = False
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = True
    'Clean up UK format dates with ordinals
    .Text = "(<[0-9]{1,2})[dhnrst ]{1,3}([JFMASOND][abceghilmnoprstuvy]{2,8}>)"
    .Replacement.Text = "\1 \2"
    .Execute Replace:=wdReplaceAll
    'Clean up & reformat US format dates with/without ordinals
    .Text = "(<[JFMASOND][abceghilmnoprstuvy]{2,8})[- ]([0-9]{1,2})[dhnrst\-, ]@([12][0-9]{3}>)"
    .Replacement.Text = "\2 \1 \3"
    .Execute Replace:=wdReplaceAll
    .Text = "(<[JFMASOND][abceghilmnoprstuvy]{2,8})[- ]([0-9]{1,2})[dhnrst]@>"
    .Replacement.Text = "\2 \1"
    .Execute Replace:=wdReplaceAll
    .Text = "(<[JFMASOND][abceghilmnoprstuvy]{2,8})[- ]([0-9]{1,2}>)"
    .Execute Replace:=wdReplaceAll
    'Clean up & reformat D/M/YYYY & D-M-YYYY UK format dates
    .Text = "[0-9]{1,2}[/-][0-9]{1,2}[/-][12][0-9]{3}>"
    .Replacement.Text = ""
  End With
  Do While .Find.Execute = True
    .Text = Format(.Text, "D MMMM YYYY")
    .Collapse wdCollapseEnd
  Loop
End With
With ActiveDocument.Range
  With .Find
    .MatchWildcards = True
    'Apply superscripted ordinals to all dates
    .Text = "<[0-9]{1,2} [JFMASOND][abceghilmnoprstuvy]{2,8}>"
    .Wrap = wdFindStop
  End With
  Do While .Find.Execute = True
    i = CLng(Split(.Text, " ")(0))
    .Text = Ordinal(i) & " " & Split(.Text, " ")(1)
    With .Duplicate
      .Start = .Start + Len(CStr(i))
      .End = .Start + 2
      .Font.Superscript = True
    End With
    .Collapse wdCollapseEnd
  Loop
End With
Application.ScreenUpdating = True
End Sub

Function Ordinal(i As Long) As String
Dim strOrd As String
If (i Mod 100) < 11 Or (i Mod 100) > 13 Then strOrd = Choose(i Mod 10, "st", "nd", "rd") & ""
Ordinal = i & IIf(strOrd = "", "th", strOrd)
End Function
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #3  
Old 05-14-2021, 11:15 PM
LQuinn LQuinn is offline find/replace date format improvement? Windows 10 find/replace date format improvement? Office 2019
Novice
find/replace date format improvement?
 
Join Date: Jan 2021
Location: Western Australia
Posts: 20
LQuinn is on a distinguished road
Default

Thanks very much Paul, always humbled at what I see you do, and what I can learn, thank you for showing a *much* better way!

Thanks again, Lee
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Mail merge field mistakenly interpret text format as date format alan6690 Mail Merge 0 09-02-2020 01:54 AM
Find/Replace using format of cell catflap Excel 1 09-11-2017 07:28 AM
Letter date changes when merging with Excel - not the format, the actual date! Smallweed Mail Merge 1 02-07-2014 06:00 PM
find/replace date format improvement? Find and Replace maintain format winningson Word 3 01-19-2013 05:38 AM
find/replace date format improvement? Find and Replace Format macro issue Jack Word VBA 2 12-12-2012 09:24 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 10:37 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft