Re-Edit existing headers in multiple files with VBA

[Sweeti]

Hello Everybody,

I would like to edit the data in headers for multiple excel files, same editing for all files.

Example:
Current data in right header of xl file1: "DOC-0021"
Current data in right header of xl file2: "DOC-0022"
Current data in right header of xl file3: "DOC-0023"

New data: "DOC-0021 DOC-0031"
"DOC-0022 DOC-0031"
"DOC-0023 DOC-0031"
* New data will include the strike through over the existing (old) data.

Can you help?

 

[Sweeti]

Hi,

I basically just need to add new text to an existing text in the header.
Every solution I found on the web is for replacing the all header with something else.

Can you help?

 

[HaHoBe]

Hi Sweeti,

maybe like this (at least for one file):

Sub MrE1171196()
'https://www.mrexcel.com/board/threads/re-edit-existing-headers-in-multiple-files-with-vba.1171196/#post-5693506

Dim strOldHD As String
Dim wks As Worksheet

Const cstrNEW As String = "DOC-0031"
    
For Each wks In Worksheets
  With wks.PageSetup
    strOldHD = .RightHeader
    Select Case strOldHD
      Case "DOC-0021", "DOC-0022", "DOC-0023"
        .RightHeader = "&S" & strOldHD & "&S" & " " & cstrNEW
      Case Else
        'do nothing
    End Select
  End With
Next wks

End Sub

Ciao,
Holger

 

[Sweeti]

Hi Holger,

Thanks for your reply.

My current code is:
Sub Add_Header_Footer()
Dim sPath As String
Dim Wb As Workbook, Ws As Worksheet
Dim sFile As String
sPath = "C:\Tests\"
sFile = Dir(sPath & "*.xlsx")
Application.ScreenUpdating = False
Do While sFile <> ""
Set Wb = Workbooks.Open(sPath & sFile)
For Each Ws In Wb.Worksheets
If Ws.PageSetup.RightHeader = Left$(Ws.Parent.Name, InStrRev(Ws.Parent.Name, ".") - 1) Then
Ws.PageSetup.RightHeader = Left$(Ws.Parent.Name, InStrRev(Ws.Parent.Name, ".") - 1) & "B"
End If
Next Ws
Wb.Close SaveChanges:=True
sFile = Dir
Loop
Application.ScreenUpdating = True
End Sub

I tried to make it to check if the right header = file name, if yes then it supposed to add "B" after the file name.
It's not working...

Can you edit your code to take advantages of automatically write the file name in the header?

 

[HaHoBe]

Hi Sweeti,

please use code-tags to display your code for better readability (and copying) - thanks.

A change for your original macro may look like this

Sub Add_Header_Footer_02()

  Dim sPath As String
  Dim Wb As Workbook
  Dim Ws As Worksheet
  Dim sFile As String
  Dim varWbName As Variant
  
  sPath = "C:\Tests\"
  sFile = Dir(sPath & "*.xlsx")
  Application.ScreenUpdating = False
  
  Do While sFile <> ""
    Set Wb = Workbooks.Open(sPath & sFile)
    varWbName = Split(Wb.Name, ".")
    For Each Ws In Wb.Worksheets
      If Ws.PageSetup.RightHeader = varWbName(0) Then
        Ws.PageSetup.RightHeader = varWbName(0) & "B"
      End If
    Next Ws
    Wb.Close SaveChanges:=True
    sFile = Dir
  Loop
  
  Application.ScreenUpdating = True

End Sub

Ciao,
Holger

 

[Sweeti]

Hi Sweeti,

please use code-tags to display your code for better readability (and copying) - thanks.

A change for your original macro may look like this

Sub Add_Header_Footer_02()

  Dim sPath As String
  Dim Wb As Workbook
  Dim Ws As Worksheet
  Dim sFile As String
  Dim varWbName As Variant
 
  sPath = "C:\Tests\"
  sFile = Dir(sPath & "*.xlsx")
  Application.ScreenUpdating = False
 
  Do While sFile <> ""
    Set Wb = Workbooks.Open(sPath & sFile)
    varWbName = Split(Wb.Name, ".")
    For Each Ws In Wb.Worksheets
      If Ws.PageSetup.RightHeader = varWbName(0) Then
        Ws.PageSetup.RightHeader = varWbName(0) & "B"
      End If
    Next Ws
    Wb.Close SaveChanges:=True
    sFile = Dir
  Loop
 
  Application.ScreenUpdating = True

End Sub

Ciao,
Holger

I run the code but it doesn't do anything probably because the existing right header contain not only the file name but other words that should be remain.
Sorry for not being more specific.

Thanks,
Sweeti.

 

[HaHoBe]

Hi Sweeti,

probably because the existing right header contain not only the file name but other words that should be remain.

should have been mentioned before.

I can´t see how that fits in with a limitation to certain values but try

Sub Add_Header_Footer_03()

  Dim sPath As String
  Dim Wb As Workbook
  Dim Ws As Worksheet
  Dim sFile As String
  Dim varWbName As Variant
  Dim strOld As String
  
  Const cstrNEW As String = "DOC-0031"
  
  sPath = "C:\Tests\"
  sFile = Dir(sPath & "*.xlsx")
  Application.ScreenUpdating = False
  
  Do While sFile <> ""
    Set Wb = Workbooks.Open(sPath & sFile)
    varWbName = Split(Wb.Name, ".")
    For Each Ws In Wb.Worksheets
      With Ws.PageSetup
        strOld = .RightHeader
        If InStr(1, strOld, varWbName(0)) > 0 Then
          .RightHeader = varWbName(0) & " " & cstrNEW
        End If
      End With
    Next Ws
    Wb.Close SaveChanges:=True
    sFile = Dir
  Loop
  
  Application.ScreenUpdating = True

End Sub

Ciao,
Holger

 

[HaHoBe]

Hi Sweeti,

an updated code (in case there is more than one dot in the workbook-name):

Sub Add_Header_Footer_03_mod()

  Dim sPath As String
  Dim Wb As Workbook
  Dim Ws As Worksheet
  Dim sFile As String
  Dim strWbName As String
  Dim strOld As String
  
  Const cstrNEW As String = "DOC-0031"
  
  sPath = "C:\Tests\"
  sFile = Dir(sPath & "*.xlsx")
  Application.ScreenUpdating = False
  
  Do While sFile <> ""
    Set Wb = Workbooks.Open(sPath & sFile)
    strWbName = Left(Wb.Name, InStrRev(Wb.Name, ".") - 1)
    For Each Ws In Wb.Worksheets
      With Ws.PageSetup
        strOld = .RightHeader
        If InStr(1, strOld, strWbName) > 0 Then
          .RightHeader = strWbName & " " & cstrNEW
        End If
      End With
    Next Ws
    Wb.Close SaveChanges:=True
    sFile = Dir
  Loop
  
  Application.ScreenUpdating = True

End Sub

Do you want to keep the whole contents of the header and add to it or exchange parts of it?

Ciao,
Holger

 

[Sweeti]

Hi Sweeti,



should have been mentioned before.

I can´t see how that fits in with a limitation to certain values but try

Sub Add_Header_Footer_03()

  Dim sPath As String
  Dim Wb As Workbook
  Dim Ws As Worksheet
  Dim sFile As String
  Dim varWbName As Variant
  Dim strOld As String
 
  Const cstrNEW As String = "DOC-0031"
 
  sPath = "C:\Tests\"
  sFile = Dir(sPath & "*.xlsx")
  Application.ScreenUpdating = False
 
  Do While sFile <> ""
    Set Wb = Workbooks.Open(sPath & sFile)
    varWbName = Split(Wb.Name, ".")
    For Each Ws In Wb.Worksheets
      With Ws.PageSetup
        strOld = .RightHeader
        If InStr(1, strOld, varWbName(0)) > 0 Then
          .RightHeader = varWbName(0) & " " & cstrNEW
        End If
      End With
    Next Ws
    Wb.Close SaveChanges:=True
    sFile = Dir
  Loop
 
  Application.ScreenUpdating = True

End Sub

Ciao,
Holger

Works Great ! Thanks!