#1
|
|||
|
|||
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 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 |
#2
|
||||
|
||||
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] |
#3
|
|||
|
|||
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 |
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 and Replace maintain format | winningson | Word | 3 | 01-19-2013 05:38 AM |
Find and Replace Format macro issue | Jack | Word VBA | 2 | 12-12-2012 09:24 PM |