Copy RightFooter, Delete Entire Footer, and Paste to LeftFooter

[breynolds0431]

Hello. I'm really stuck on coming up with a viable line of code to do the following:

My Word doc has a footer with data in the left, center, and right areas. The right footer area will always have two lines. The first, a five digit number and the second, a date. The document already copies a letterhead, via a end-user form, from a network intranet where multiple different office letterheads are stored. When the end-user uses the form to select their office, the left and right footers need to be deleted, leaving only the two lines of data in the right footer. Also, the right footer would need to be left-aligned.

Is there a way to do this? I was thinking to copy the two right footer lines, deleting the entire footer contents, and then pasting the clipboard.

Thank you in advance for any expertise you could share.

 

[Macropod]

Word documents don't have left, centre or right footers - they just have footers that span the entire page width. However, without detailed knowledge of what else is on the two 'lines' of interest and how they are formatted, plus their relationship to whatever else is to be deleted or added, it's impossible to give specific advice.

 

[breynolds0431]

I don't see any options on attaching an example of the footer. But, t consists of the FILENAME (left-aligned, multiple lines), the Page # of # (center-aligned), and a ID and Publish Date (right-align, 2-lines). The Publish Date should never update to a current date. The footer utilizes paragraphs instead of a table, which is not ideal but also not in my power to revise. Ideally, only the ID and Publish Date should remain and be moved to the left alignment. Below is the current code, which pulls in a user-defined (form) office template.

Private Sub cmdLetterhead_Click()
'adds letterhead to document from intranet, based on office selected via frmOffice
    Dim tmpDir As String, tmpFile As String, tmpFileRev As String
    Dim Rng As Range, Rng2 As Range
    Dim FileLocation
    Dim i As Integer

    iOffice = -1 'initializes variable
    frmOffice.Show  'user form for users to select office

    If bOffice Then Exit Sub

    If Me.ProtectionType = wdAllowOnlyFormFields Then _
        Me.Unprotect

    If iOffice < 0 Then  'no office selected
        Me.Sections(1).Headers(wdHeaderFooterFirstPage).Range.Delete
        Selection.HomeKey wdStory
        Me.Protect Type:=wdAllowOnlyFormFields, NoReset:=True
        Me.FormFields("Text2").Select
        Exit Sub
    End If

        tmpDir = "[URL="http://adminastar.com/intranet/marketing/"][COLOR=#22229c]http://adminastar.com/intranet/marketing/[/COLOR][/URL]"

'populates array for use with frmOffice combobox result
'array must be in same order as City array located in frmOffice
    FileLocation = Array( _
        "letterhead/100_roscommon_drive_CT.docx", "letterhead/1301_pennsylvania_Ave_DC.docx", "letterhead/1351_william_howard_taft_road_OH.docx", "letterhead/13550_triton_office_park_blvd_KY.docx", "letterhead/2_gannett_drive_ME.docx", "letterhead/200_isaac_shelby_drive_KY.docx", _
        "letterhead/20711_watertown_road_WI.docx", "letterhead/2245_rolling_run_drive_MD.docx", "letterhead/2400_thea_drive_PA.docx", "letterhead/26555_evergreen_road_MI.docx", "letterhead/3000_goffs_falls_road_NH.docx", "letterhead/4203_williamson_place_IL.docx", _
        "letterhead/5000_brittonfield_parkway_NY.docx", "letterhead/6775_west_washington_street_WI.docx", "letterhead/7133_rutherford_road_MD.docx", "letterhead/8002_discovery_drive.docx", "letterhead/8002_discovery_drive_VA.docx", "letterhead/8115_knue_road_IN.docx", _
        "letterhead/A_CMS_Contracted_Agent_8115_knue_road_IN.docx", "letterhead/po_box_4776_NY.docx", "letterhead/po_box_4811_NY.docx", "letterhead/po_box_4900_NY.docx", "letterhead/po_box_6036_NY.docx", "letterhead/po_box_6130_congressional.docx", "letterhead/po_box_6131_foia.docx", "letterhead/po_box_6130_IN_congressional.docx", _
        "letterhead/po_box_6131_IN.docx", "letterhead/po_box_7050_IN.docx", "letterhead/po_box_6160_IN.docx", "letterhead/po_box_6189_IN.docx", "letterhead/po_box_6230_IN.docx", _
        "letterhead/po_box_6474_IN.docx", "letterhead/po_box_6475_IN.docx", "letterhead/po_box_7051_IN.docx", "letterhead/po_box_7053_IN.docx", "letterhead/po_box_7064_IN.docx", "letterhead/po_box_7073_IN.docx", "letterhead/po_box_7078_IN.docx", "letterhead/po_box_7091_IN.docx", "letterhead/po_box_7108_IN.docx", _
        "letterhead/po_box_7111_IN.docx", "letterhead/po_box_7141.docx", "letterhead/po_box_7141_IN_1-800.docx", "letterhead/po_box_7141_IN_PROV.docx", "letterhead/po_box_7141_IN_PROV_DUP.docx", "letterhead/po_box_7149.docx", "letterhead/po_box_7155_IN.docx", "letterhead/po_box_7191_IN.docx", "letterhead/po_box_7191_IN_CC_0990.docx")
    Application.ScreenUpdating = False
'deletes current letterhead and MARP header/footer if they exist
    With Me.Sections(1)
        With .Headers(wdHeaderFooterFirstPage)
            .Range.Delete
            On Error Resume Next
            For i = 1 To .Shapes.Count
                .Shapes(i).Delete
            Next i
            On Error GoTo 0
        End With
        With .Headers(wdHeaderFooterPrimary)
            .Range.Delete
            On Error Resume Next
            For i = 1 To .Shapes.Count
            .Shapes(i).Delete
            Next i
            On Error GoTo 0
        End With
        .Headers(wdHeaderFooterPrimary).Range.Delete

        On Error Resume Next
        With .Footers(wdHeaderFooterFirstPage)
            For i = 1 To .Shapes.Count
                .Shapes(i).Delete
            Next i
        End With

        .Footers(wdHeaderFooterPrimary).Range.Delete

        On Error GoTo 0

    Documents.Open tmpDir & FileLocation(iOffice)
'copies letterhead image from template to this document
    Set Rng = ActiveDocument.Sections(1).Headers(wdHeaderFooterFirstPage).Range
    Rng.Copy
    With Me.Sections(1).Headers(wdHeaderFooterFirstPage).Range
        .Paste
        .Paragraphs(2).Alignment = wdAlignParagraphLeft
    End With

     Set Rng = ActiveDocument.Sections(1).Footers(wdHeaderFooterFirstPage).Range
        Rng.Copy
        Me.Sections(1).Footers(wdHeaderFooterFirstPage).Range.Paste

    ActiveDocument.Close False

    Me.Protect Type:=wdAllowOnlyFormFields, NoReset:=True
    Me.FormFields("Text2").Select

    Application.ScreenUpdating = True
End With

End Sub

 

[Macropod]

Cross-posted at: Copy RightFooter, Delete Entire Footer, and Paste to LeftFooter

For cross-posting etiquette, please read: Excelguru Help Site - A message to forum cross posters