Macro to Loop Through H/F (2000 and up)

Topic

New Reply

I

Reply | Quote

Replies

Try this for the first one:

Sub AdminRemoveDraft()
Dim sec As Section
Dim hdr As HeaderFooter
For Each sec In ActiveDocument.Sections
For Each hdr In sec.Headers
If hdr.Exists Then
hdr.Range.Delete
End If
Next hdr
Next sec
End Sub

Reply | Quote

It’s not very clear what the second macro tries to do in the footer, since it relies on moving the selection, and it doesn’t correspond to your description.

Reply | Quote

The 2nd macro searches the document for highlighted E/A and changes to either Engineer or Architect then goes into each footer and replaces the date field code with an underline.

I’ll attach the document that this would be used on. Sorry I wasn’t more clear.

Again, thanks

Reply | Quote

Try this:

Sub EngSpecFoot()
‘ EngSpecFoot Macro
‘ Delete date code and replace with file number, change E/A to Engineer
‘ and delete highlighting from Engineer
‘
Dim sec As Section
Dim ftr As HeaderFooter
Dim fld As Field
Dim rng As Range

With Selection.Find
.ClearFormatting
.Highlight = True
.Replacement.ClearFormatting
.Replacement.Highlight = False
.Text = “E/A”
.Replacement.Text = “Engineer”
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With

For Each sec In ActiveDocument.Sections
For Each ftr In sec.Footers
If ftr.Exists Then
For Each fld In ftr.Range.Fields
If fld.Type = wdFieldSaveDate Then
Set rng = fld.Result
rng.Delete
rng.Text = “____________”
End If
Next fld
End If
Next ftr
Next sec
End Sub

Reply | Quote

Once again, you’ve come through for me. Both macros work perfectly.

Reply | Quote