I have a userform with 5 checkbox buttons for 5 pdf versions.
Well, when the user calls the userform, then the userform initializes 5 checkbox buttons to select one of them. At the moment, the code is very static and not so good.
Here the example:
If rs.EOF = False Then
Do Until rs.EOF Or i = 5
Select Case i
Case Is = 0
frmOne.Version5.Visible = True
frmOne.Version5.Caption = rs!versNo & "#" & rs!versFrom
frmOne.Version5.tag = rs!versNo & "_" & rs!FiD & ".pdf"
Case Is = 1
frmOne.Version4.Visible = True
frmOne.Version4.Caption = rs!versNo & "#" & rs!versFrom
frmOne.Version4.tag = rs!versNo & "_" & rs!FiD & ".pdf"
Case Is = 2
frmOne.Version3.Visible = True
frmOne.Version3.Caption = rs!versNo & "#" & rs!versFrom
frmOne.Version3.tag = rs!versNo & "_" & rs!FiD & ".pdf"
Case Is = 3
frmOne.Version2.Visible = True
frmOne.Version2.Caption = rs!versNo & "#" & rs!versFrom
frmOne.Version2.tag = rs!versNo & "_" & rs!FiD & ".pdf"
Case Is = 4
frmOne.Version1.Visible = True
frmOne.Version1.Caption = rs!versNo & "#" & rs!versFrom
frmOne.Version1.tag = rs!versNo & "_" & rs!FiD & ".pdf"
End Select
i = i + 1
rs.MoveNext
Loop
End If
To much code I think. So my intention was to define it like the example below, but this doesn't work:
If rs.EOF = False Then
For i = 1 To 5
With frmOne
.Version & i &.Visible = True
.Version & i &.Caption = rs!versNo & "#" & rs!versFrom
.Version & i &.tag = rs!versNo & "_" & rs!FiD & ".pdf"
End With
rs.MoveNext
Next i
End If
Do have anyone an idea how could I fix that?
You can refer to the Controls collection using the name:
If rs.EOF = False Then
For i = 1 To 5
With frmOne.Controls("Version" & i)
.Visible = True
.Caption = rs!versNo & "#" & rs!versFrom
.tag = rs!versNo & "_" & rs!FiD & ".pdf"
End With
rs.MoveNext
Next i
End If
To actually add the controls at runtime too:
Do While not rs.EOF
i = i + 1
With frmOne.Controls.Add("Forms.CheckBox.1", "Version" & i, True)
.Caption = rs!versNo & "#" & rs!versFrom
.tag = rs!versNo & "_" & rs!FiD & ".pdf"
End With
rs.MoveNext
Loop
go like follows:
If rs.EOF = False Then
For i = 1 To 5
With frmOne.Controls("Version" & i) '<~~ use Controls collection of Userform object
.Visible = True
.Caption = rs!versNo & "#" & rs!versFrom
.Tag = rs!versNo & "_" & rs!FiD & ".pdf"
End With
rs.MoveNext
Next i
End If
Related
Im altering the code of a Script that is used to automatically paste an outlook signature based on AD. Now im having some problems with making the formatting work
I have one cell that contains most of the usefull information but i need the firstname and Lastname to be bold. And the other info on the same lines and below it to follow the format info that was given above it
I tried seperating the code in different cells but the formatting goes all wrong then
objTable.Cell(1, 2).Range.Text = strFirstName & " " & strLastName & " | " & strTitle & Chr(11) & strDepartment & Chr (11) & Chr(11) & strAdress & ", " & strPostal & " " & strCity & Chr (11) & "T" & " " & strPhone & strTelefoon & Chr (11) & "E " & strEmail
strFirstName and strLastName should be in bold
Try:
With objTable.Cell(1, 2).Range
.Text = strFirstName & " " & strLastName & " | " & strTitle & Chr(11) & _
strDepartment & Chr(11) & Chr(11) & _
strAdress & ", " & strPostal & " " & strCity & Chr(11) & _
"T" & " " & strPhone & strTelefoon & Chr(11) & _
"E " & strEmail
.End = .Start + InStr(.Text, " | ") - 1
.Font.Bold = True
End With
Thanks for all the answers!
I fixed it by going with .select
objTable.Cell(1,2).select
objSelection.Font.Name = "Calibri Light"
objSelection.Font.Size = "11"
objSelection.Font.Color = RGB(23,68,153)
If strFirstName <> "" Then
objSelection.Font.Bold = True
objSelection.TypeText strFirstName & " " & strLastName
objSelection.Font.Bold = False
End If
If strTitle <> "" Then
ObjSelection.TypeText " | " & strTitle
End If
ObjSelection.TypeText (Chr(11))
ObjSelection.TypeText strDepartment
ObjSelection.TypeText (Chr(11))
If strFirstName <> "" Then
objSelection.Font.size = 5
objSelection.TypeText " "
objSelection.Font.size = 11
End If
ObjSelection.TypeText (Chr(11))
ObjSelection.TypeText strAdress & ", " & strPostal & " " & strCity
ObjSelection.TypeText (Chr(11))
If strPhone <> "" Then
objSelection.Font.Bold = True
objSelection.TypeText "T "
objSelection.Font.Bold = False
End If
ObjSelection.TypeText strPhone
If strGSM <> "" Then
objSelection.TypeText " | "
objSelection.Font.Bold = True
objSelection.TypeText " G "
objSelection.Font.Bold = False
End If
ObjSelection.TypeText strTelefoon
ObjSelection.TypeText (Chr(11))
If strEmail <> "" Then
objSelection.Font.Bold = True
objSelection.TypeText "E "
objSelection.Font.Bold = False
objSelection.TypeText strEmail
End If
Is it possible to open an existing application window?
What I want:
What is the code in order to put focus on an already open, but not in focus, application. For example, with:
Set objIE = New InternetExplorer
but I want the macro to put focus on an already existing IE.
Here is another case, I let Lotus notes create an email with the following code:
Sub Email_Bot()
'variables are defined
Dim Maildb As Object
Dim UserName As String
Dim MailDbName As String
Dim MailDoc As Object
Dim Session As Object
Dim AttachME As Object
Dim EmbedObj As Object
Dim Attachment As String
Dim stAttachment As String
Dim Mail_Form As String
Dim Mail_SendTo As String
Dim Mail_Subject As String
Dim Mail_Body As String
Dim Mail_Attachement As Boolean
Dim Mail_Save As Boolean
Dim Mail_Send As Boolean
Dim Mail_Name As String
Dim Mail_Text_1 As String
Dim Mail_Text_2 As String
Dim Mail_Text_3 As String
Dim Mail_Text_4 As String
Dim Mail_Text_5 As String
Dim Mail_Text_6 As String
Dim Mail_Closing As String
Dim Mail_SendBy As String
Dim tb_Mailing_List As Object
Dim tb_Email_Template As Object
Dim LastRow As Integer
Dim Row_Count As Integer
Dim Mail_Body_Lock As Boolean
Dim Workspace As Object
Const EMBED_ATTACHMENT As Long = 1454
'worksheets are defined
Set tb_Mailing_List = ThisWorkbook.Sheets("Mailing List")
Set tb_Email_Template = ThisWorkbook.Sheets("Email Template")
'mail session is defined
Set Session = CreateObject("Notes.NotesSession")
Set Maildb = Session.CURRENTDATABASE
Set MailDoc = Maildb.CREATEDOCUMENT
Set Workspace = CreateObject("Notes.NOTESUIWORKSPACE")
'important variables are set
LastRow = tb_Mailing_List.Cells(Rows.Count, 2).End(xlUp).Row
Row_Count = 3
Mail_Body_Lock = False
'cell assignment
Mail_Text_1 = tb_Email_Template.Cells(4, 4).Value
Mail_Text_2 = tb_Email_Template.Cells(5, 4).Value
Mail_Text_3 = tb_Email_Template.Cells(6, 4).Value
Mail_Text_4 = tb_Email_Template.Cells(7, 4).Value
Mail_Text_5 = tb_Email_Template.Cells(8, 4).Value
Mail_Text_6 = tb_Email_Template.Cells(9, 4).Value
Mail_Closing = tb_Email_Template.Cells(25, 4).Value
Mail_SendBy = tb_Email_Template.Cells(12, 4).Value & vbNewLine & vbNewLine & tb_Email_Template.Cells(13, 4).Value & vbNewLine & tb_Email_Template.Cells(14, 4).Value & vbNewLine & tb_Email_Template.Cells(15, 4).Value & vbNewLine & vbNewLine & tb_Email_Template.Cells(16, 4).Value & vbNewLine & tb_Email_Template.Cells(17, 4).Value & vbNewLine & tb_Email_Template.Cells(18, 4).Value & vbNewLine & tb_Email_Template.Cells(19, 4).Value & vbNewLine & tb_Email_Template.Cells(20, 4).Value & vbNewLine & tb_Email_Template.Cells(21, 4).Value & vbNewLine & tb_Email_Template.Cells(22, 4).Value
'loops until all names have been filled
Do Until Row_Count = LastRow + 1
'Mail Dashboard
Mail_Body_Lock = False
Mail_Send = False
Mail_Form = "Memo"
Mail_Name = tb_Mailing_List.Cells(Row_Count, 2).Value
Mail_SendTo = tb_Mailing_List.Cells(Row_Count, 4).Value
Mail_Subject = tb_Email_Template.Cells(2, 4).Value
Mail_Save = True
'exit round in case the email address is not present
If Mail_SendTo = "" Then GoTo NoEmail
'if only body row 1 has text
If Mail_Text_2 = "" And Mail_Text_3 = "" And Mail_Text_4 = "" And Mail_Text_5 = "" And Mail_Text_6 = "" Then
Mail_Body = "Dear " & Mail_Name & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
Mail_Body_Lock = True
End If
'if only body row 1 and row 2 have text
If Mail_Body_Lock = False And Mail_Text_3 = "" And Mail_Text_4 = "" And Mail_Text_5 = "" And Mail_Text_6 = "" Then
Mail_Body = "Dear " & Mail_Name & "," & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & Mail_Text_2 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
Mail_Body_Lock = True
End If
'if only body row 1 till row 3 have text
If Mail_Body_Lock = False And Mail_Text_4 = "" And Mail_Text_5 = "" And Mail_Text_6 = "" Then
Mail_Body = "Dear " & Mail_Name & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & Mail_Text_2 & vbNewLine & Mail_Text_3 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
Mail_Body_Lock = True
End If
'if only body row 1 till row 4 have text
If Mail_Body_Lock = False And Mail_Text_5 = "" And Mail_Text_6 = "" Then
Mail_Body = "Dear " & Mail_Name & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & Mail_Text_2 & vbNewLine & Mail_Text_3 & vbNewLine & Mail_Text_4 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
Mail_Body_Lock = True
End If
'if only body row 1 till row 5 have text
If Mail_Body_Lock = False And Mail_Text_6 = "" Then
Mail_Body = "Dear " & Mail_Name & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & Mail_Text_2 & vbNewLine & Mail_Text_3 & vbNewLine & Mail_Text_4 & vbNewLine & Mail_Text_5 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
Mail_Body_Lock = True
End If
'in case there is an error or something
If Mail_Body_Lock = False Then
Mail_Body = "Dear " & Mail_Name & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & Mail_Text_2 & vbNewLine & Mail_Text_3 & vbNewLine & Mail_Text_4 & vbNewLine & Mail_Text_5 & vbNewLine & Mail_Text_6 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
End If
'mail build-up
MailDoc.Form = Mail_Form
MailDoc.SendTo = Mail_SendTo
MailDoc.Subject = Mail_Subject
MailDoc.Body = Mail_Body
'attachement build-up
If tb_Email_Template.Cells(28, 4) <> "" And tb_Email_Template.Cells(29, 4) <> "" Then
Attachment = tb_Email_Template.Cells(28, 4)
stAttachment = tb_Email_Template.Cells(29, 4)
Set AttachME = MailDoc.CREATERICHTEXTITEM("stAttachment")
Set EmbedObj = AttachME.EmbedObject(EMBED_ATTACHMENT, "", Attachment, "stAttachment")
End If
Call Workspace.EDITDOCUMENT(True, MailDoc).GOTOFIELD("Body")
MsgBox "Email send?"
NoEmail:
Row_Count = Row_Count + 1
Loop
'variable dump
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj = Nothing
End Sub
After:
Call Workspace.EDITDOCUMENT(True, MailDoc).GOTOFIELD("Body")
I want to VBA to open that window and not that I have to go there by myself. I am sure that there has to be a way. I used mouse movements, which worked until a colleague with a different screen res. used the program.
I am quite new to VBA and programming and taught myself so I am sorry if this is maybe a dumb question, but I couldn't find the answer so far anywhere else.
Try This way,
Public vPID As Variant
Public Sub OpenApplication()
'Launch application if not already open
If vPID = 0 Then 'Application not already open
101:
vPID = Shell("C:\Windows\system32\notepad.exe", vbNormalFocus)
Else 'Application already open so reactivate
On Error GoTo 101
AppActivate (vPID)
End If
End Sub
Because the variable vPID is stored as a project level Public Variable, its value will be retained for as long as your instance of Excel (or other Microsoft Office application) is open.
This code is designed to detect the columns of start and finish of a shape which is used and displayed onto the caption of the shape itself. The following code is the problematic code:
Sub Take_Baseline()
Dim forcast_weeksStart() As String
Dim forcast_weeksEnd() As String
Dim forcastDate As String
Dim shp As Shape
Dim split_text() As String
'cycle through all the shapes in the worsheet and enter the forcast date for all the projects into their respective boxes
For Each shp In ActiveSheet.Shapes
'initialize forcast date by parsing
forcast_weeksStart = Split(shp.TopLeftCell.Column.Text, " ")
forcast_weeksEnd = Split(shp.BottomRightCell.Column.Text, " ")
forcastDate = forcast_weeksStart(1) & "-" & forcast_weeksEnd(1)
temp = shp.OLEFormat.Object.Object.Caption
If InStr(temp, "/-/") > 0 & InStr(temp, "In Prog") Then
split_text = Split(shp.OLEFormat.Object.Caption, " ")
For i = 0 To (i = 3)
shp.TextFrame.Characters.Caption = split_text(i) & vbNewLine
Next i
ActiveSheet.Shapes(Sheet4.Range("B1")).TextFrame.Characters.Caption = ActiveSheet.Shapes(Sheet4.Range("B1")).TextFrame.Characters.Caption & vbNewLine & ActiveSheet.Cells(4, AShape.TopLeftCell.Column).Text & " - " & ActiveSheet.Cells(4, AShape.BottomRightCell.Column).Text & vbNewLine & "dates: " & forcast_weeksStart(1) & " - " & forcast_weeksEnd(1) & "/" & forcast_weeksStart(1) & " - " & forcast_weeksEnd(1) & "/" & "/" & "actualDate"
' ElseIf InStr(temp, "/-/") > 0 & InStr(temp, "In Prog") = 0 Then
'split_text = Split(shp.OLEFormat.Object.Object.Caption, " ")
' For i = 0 To (i = 2)
' shp.OLEFormat.Object.Caption = split_text(i) & vbNewLine
' Next i
'ActiveSheet.Shapes(Sheet4.Range("B1")).TextFrame.Characters.Caption = ActiveSheet.Shapes(Sheet4.Range("B1")).TextFrame.Characters.Caption & vbNewLine & "In Prog" & vbNewLine & ActiveSheet.Cells(4, AShape.TopLeftCell.Column).Text & " - " & ActiveSheet.Cells(4, AShape.BottomRightCell.Column).Text & vbNewLine & "dates: " & forcast_weeksStart(1) & " - " & forcast_weeksEnd(1) & "/" & forcast_weeksStart(1) & " - " & forcast_weeksEnd(1) & "/" & "actualDate"
End If
Next shp
'For testing purposes
Sheet4.Range("A20").Value = forcast_weeksStart(1)
Sheet4.Range("A21").Value = forcast_weeksEnd(1) End Sub
The error is an
"invalid qualifier"
message which occurs on line
forcast_weeksStart = Split(shp.TopLeftCell.Column.Text, " ")
Right on the "column" word. I don't get why this is happening since the actual drop down menu has the column operation which i can select. I have tried everything from changing it to the OLEformat.Object.Caption etc etc. But nothing has worked. I am still relatively new to vba so any help will be appreciated. Thanks
I have some code to pdf and save my file to a folder on my computer. I've tested in the past and had no problem. However, after making some minor changes i am getting run time error 1004. Any ideas on why this is? Very frustrating. Thank you.
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim i As Long
Dim ws As Worksheet
Dim FileName As String
Set ws = Sheets("Multi")
Set wsJob = Sheets("Job")
FileName = ws.Range("B2")
LastRow = ws.Range("B" & Rows.Count).End(xlUp).Row
For i = 8 To LastRow
wsJob.Activate
wsJob.Range("AZ1").Value = ws.Range("B" & i)
wsJob.Range("AZ2").Value = ws.Range("C" & i)
wsJob.Range("AZ3").Value = ws.Range("D" & i)
wsJob.Range("AZ4").Value = ws.Range("E" & i)
wsJob.Range("AZ5").Value = ws.Range("F" & i)
wsJob.Range("AZ6").Value = ws.Range("G" & i)
wsJob.ComboBox1.Visible = False
wsJob.ComboBox2.Visible = False
wsJob.ComboBox3.Visible = False
wsJob.ComboBox4.Visible = False
wsJob.ComboBox5.Visible = False
wsJob.ComboBox6.Visible = False
wsJob.CommandButton1.Visible = False
wsJob.Rows("4:13").EntireRow.Hidden = True
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=ws.Range("B2") & "TCC Analysis - " & ws.Range("B" & i) & " - " & ws.Range("C" & i) & " - " & ws.Range("D" & i) & " - " & ws.Range("E" & i) & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
Next i
wsJob.ComboBox1.Visible = True
wsJob.ComboBox2.Visible = True
wsJob.ComboBox3.Visible = True
wsJob.ComboBox4.Visible = True
wsJob.ComboBox5.Visible = True
wsJob.ComboBox6.Visible = True
wsJob.CommandButton1.Visible = True
wsJob.Rows("4:13").EntireRow.Hidden = False
ws.Activate
Application.ScreenUpdating = True
End Sub
Replace this line;
FileName:=ws.Range("B2") & "TCC Analysis - " & ws.Range("B" & i) & " - " & ws.Range("C" & i) & " - " & ws.Range("D" & i) & " - " & ws.Range("E" & i) & ".pdf"
with this;
FileName:=ws.Range("B2").value & "TCC Analysis - " & ws.Range("B" & i).value & " - " & ws.Range("C" & i).value & " - " & ws.Range("D" & i).value & " - " & ws.Range("E" & i).value & ".pdf"
Replace;
wsJob.Range("AZ1").Value = ws.Range("B" & i)
wsJob.Range("AZ2").Value = ws.Range("C" & i)
wsJob.Range("AZ3").Value = ws.Range("D" & i)
wsJob.Range("AZ4").Value = ws.Range("E" & i)
wsJob.Range("AZ5").Value = ws.Range("F" & i)
wsJob.Range("AZ6").Value = ws.Range("G" & i)
with this;
wsJob.Range("AZ1").Value = ws.Range("B" & i).Value
wsJob.Range("AZ2").Value = ws.Range("C" & i).Value
wsJob.Range("AZ3").Value = ws.Range("D" & i).Value
wsJob.Range("AZ4").Value = ws.Range("E" & i).Value
wsJob.Range("AZ5").Value = ws.Range("F" & i).Value
wsJob.Range("AZ6").Value = ws.Range("G" & i).Value
Replace
FileName = Sheets("Multi").Range("B2")
with this
FileName = Sheets("Multi").Range("B2").value
Change FileName decleration with different string because FileName is also using in the ActiveSheet.ExportAsFixedFormat line...
This macro is to set a four line left header for all the worksheets in the workbook. The point of this macro is to have control of each line's font size, and attribute i.e bold. I have a separate sheet called header that has the values I use. It will work for 3 lines, but when I add the fourth it bugs out.
I get this error.
Run-time error '1004':
Unable to set the LeftHeader property of the PageSetup class
Also note I am running Excel 2010 64 bit.
Sub Header()
'
' Header Macro
'
lHeader = "&""Calibri,Regular""&10" & Worksheets("Header").Range("B2").Value
lHeader = lHeader & Chr(13) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("B3").Value
lHeader = lHeader & Chr(13) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("B4").Value
lHeader = lHeader & Chr(13) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("B5").Value
Dim Naam As String, NameFile() As String
ReDim NameFile(1 To Sheets.Count)
With Application
.ScreenUpdating = False
i = 1
For Each shtNext In Sheets
With Sheets(i).PageSetup
.LeftHeader = lHeader
.LeftFooter = Format(Now, "mmmm d, yyyy")
.CenterFooter = "&""Calibri,Regular""&10" & Format(Worksheets("Header").Range("C8").Value)
.RightFooter = "&""Calibri,Regular""&10" & Format(Worksheets("Header").Range("D8").Value) & "&p of &N"
End With
i = i + 1
Next shtNext
End With
End Sub
You are getting that error because you are exceeding the 255 character limit. Unfortunately I couldn't find an MSDN article to back it up but it can be easily re-produced.
The current lengths that you have is
HeaderL - 121
HeaderC - 112
HeaderR - 121
Total - 354
Try this code. Here you can experiment it to reduce the characters.
Sub Header()
HeaderL = "&""Calibri,Regular""&10" & Worksheets("Header").Range("B2").Value
HeaderL = HeaderL & Chr(10) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("B3").Value
HeaderL = HeaderL & Chr(10) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("B4").Value
HeaderL = HeaderL & Chr(10) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("B5").Value
HeaderC = "&""Calibri,Bold""&14" & Worksheets("Header").Range("C2").Value
HeaderC = HeaderC & Chr(10) & "&""Calibri,Bold""&14" & Worksheets("Header").Range("C3").Value
HeaderC = HeaderC & Chr(10) & "&""Calibri,Bold""&14" & Worksheets("Header").Range("C4").Value
HeaderC = HeaderC & Chr(10) & "&""Calibri,Regular""&14" & Worksheets("Header").Range("B5").Value
HeaderR = "&""Calibri,Regular""&10" & Worksheets("Header").Range("D2").Value
HeaderR = HeaderR & Chr(10) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("D3").Value
HeaderR = HeaderR & Chr(10) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("D4").Value
HeaderR = HeaderR & Chr(10) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("D5").Value
If Len(HeaderL) + Len(HeaderC) + Len(HeaderR) > 255 Then
MsgBox "Oops, You have exceeded the character limit. Please reduce it and try again"
Exit Sub
End If
Dim ws As WorkSheet
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Sheets
With ws.PageSetup
.LeftHeader = HeaderL
.CenterHeader = HeaderC
.RightHeader = HeaderR
.LeftFooter = Format(Now, "mmmm d, yyyy")
.CenterFooter = "&""Calibri,Regular""&10" & Format(Worksheets("Header").Range("C8").Value)
.RightFooter = "&""Calibri,Regular""&10" & Format(Worksheets("Header").Range("D8").Value) & "&p of &N"
End With
Next ws
Application.ScreenUpdating = True
End Sub
The 255 character limit is for real, even when separating the macros. The font values are a big part of the total. So I removed them all execpt the last line. But If I ever need a report that has different font sizes. I have a little wiggle room to change 2 of the lines without it getting too big.
LHeader = Worksheets("Header").Range("B2").Value
LHeader = LHeader & Chr(10) & Worksheets("Header").Range("B3").Value
LHeader = LHeader & Chr(10) & Worksheets("Header").Range("B4").Value
LHeader = "&""Calibri,Regular""&10" & LHeader & Chr(10) & Worksheets("Header").Range("B5").Value
CHeader = Worksheets("Header").Range("C2").Value
CHeader = CHeader & Chr(10) & Worksheets("Header").Range("C3").Value
CHeader = CHeader & Chr(10) & Worksheets("Header").Range("C4").Value
CHeader = "&""Calibri,Bold""&14" & CHeader & Chr(10) & Worksheets("Header").Range("B5").Value
RHeader = Worksheets("Header").Range("D2").Value
RHeader = RHeader & Chr(10) & Worksheets("Header").Range("D3").Value
RHeader = RHeader & Chr(10) & Worksheets("Header").Range("D4").Value
RHeader = "&""Calibri,Regular""&10" & RHeader & Chr(10) & Worksheets("Header").Range("D5").Value