تعديل كود لوضع Header,Footer

[omhamzh]

الاخوة الافاضل
قمت بتسجيل ماكرو لعمل Header,Footer
احتاج تعديله ليعمل تلقائيا بحيث
يوضع بالحدث thisworkbook
لعمل header وايضا عمل Footer
ادراج التاريخ فى Footer وعدد الاوراق
بحيث تكون بكل الاوراق لان عملها يدويا مع كبر الملف امر مرهق
بارك الله فيكم كل عام وانتم بخير

Option Explicit

Sub header()
'
' header Macro
'

'
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = "" & Chr(10) & "&""-,Bold""&12بسم الله الرحمن الرحيم"
        .RightHeader = "&""-,Bold""الحمد لله   "
        .LeftFooter = ""
        .CenterFooter = "" & Chr(10) & "&""-,Bold""&12فى حفظ الله" & Chr(10) & "&P"
        .RightFooter = "&D"
        .LeftMargin = Application.InchesToPoints(0.708661417322835)
        .RightMargin = Application.InchesToPoints(0.708661417322835)
        .TopMargin = Application.InchesToPoints(0.748031496062992)
        .BottomMargin = Application.InchesToPoints(0.748031496062992)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
End Sub

 

header.xlsm

[بن علية حاجي]

السلام عليكم ورحمة الله

جرب المرفق لعل فيه ما تريد...

بن علية حاجي

header.xlsm

[omhamzh]

اشكرك استاذ بن علية 

الكود لم يعمل للاسف

تعبك مشكور اخى بارك الله فيك

[omhamzh]

وجدت هذا الكود باليوتيوب

عن طريق الكتابة بالسطر الاول يمكن عمل HEADER&FOOTER
بهذا الكود الكتابة من اول الخلية A1
 

Private Sub Workbook_BeforePrint(Cancel As Boolean)
With ActiveSheet.PageSetup
    .RightHeader = Sheet1.Cells(1, 1).Value
    .CenterHeader = Sheet1.Cells(1, 2).Value
    .LeftHeader = Sheet1.Cells(1, 3).Value
    .RightFooter = Sheet1.Cells(1, 4).Value & Date
    .LeftFooter = Sheet1.Cells(1, 5).Value
End With
End Sub

لعله يفيد اخواتى