I have been using this macro for years. I have rewritten it several times. I find it to be quiet useful. It is comprised of four subroutines. The first two are the work I need done. The third evaluates the conditional that work is predicated on and calls the 2nd or 1st and 2nd. The 4th calls the 3rd and is bound to a keyboard shortcut in order to decouple the execution from the keyboard binding.
The first subroutine is called date header. As the name suggests it inserts a date header. I use header one for the date. For the purpose of keeping a journal, this is useful as it displays at the top level of the navigation pane (which has a checkbox on the view tab).
Sub DateHeader() ' ' DateHeader Macro ' Insert H1 Current Date ' Selection.Style = ActiveDocument.Styles("Heading 1") Selection.InsertDateTime DateTimeFormat:="dddd, MMMM dd, yyyy", _ InsertAsField:=False, DateLanguage:=wdEnglishUS, CalendarType:= _ wdCalendarWestern, InsertAsFullWidth:=False Selection.TypeParagraph End Sub
The second subroutine is called time header. This subroutine inserts the current time in header 2. This appears subordinate to the date which is in header 1 on the navigation pane. This allows collapsing the navigation pane to the date level.
Sub timeHeader() ' ' timeHeader Macro ' Insert current time in H2 ' Selection.Style = ActiveDocument.Styles("Heading 2") Selection.InsertDateTime DateTimeFormat:="h:mm am/pm", InsertAsField:= _ False, DateLanguage:=wdEnglishUS, CalendarType:=wdCalendarWestern, _ InsertAsFullWidth:=False Selection.TypeParagraph End Sub
The third is called find today. This macro searches for an existing current date header and inserts one if there isn’t one. It also inserts the time. The same work can be accomplished with 4 fewer lines of code. Comment if you see it.
Sub FindToday() ' ' FindToday Macro ' This macro searches for the existence of the date header and inserts it at the end of the document if it is not found. ' If the date header is found it inserts the time at the end. Dim vToday As String vToday = Format(Now(), "dddd, MMMM dd, yyyy") Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Heading 1") With Selection.Find .Text = vToday .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute If Selection.Text = vToday _ Then Selection.EndOf Unit:=wdStory, Extend:=wdMove Selection.TypeParagraph Application.Run "timeHeader" Else Selection.EndOf Unit:=wdStory, Extend:=wdMove Selection.TypeParagraph Application.Run "DateHeader" Application.Run "timeHeader" End If End Sub
The third subroutine is call run ctrl alt D. This decouples the key binding from the execution. It affords the option to run additional or different subroutines for the ctrl alt D keyboard combination (this can done via a dialog launched by the customize button under the commands pane of the customize ribbon dialog of the options window launched from the home/file tab). I can also delete this macro if I need to start using that keyboard shortcut for its default purpose which is to insert a footnote reference to the current cursor location.
Sub runCtrlAltD() ' ' runCtrlAltD Macro ' Replace insert footnote with macro execution. ' Application.Run MacroName:="FindToday" End Sub