بعض اكواد لماكرو اكسيل بسيطة

[اشرف السيد]

Sub طابعة()
'
' طابعة Macro
' Macro recorded 31/03/2014 by ashlolo
'ترتيب عزمود E ابجديا
    Columns("E:E").Select
    Range("E5").Activate
    Selection.Sort Key1:=Range("E5"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        
        'SAVE workbook
    ActiveWorkbook.Save
    
    'حفظ مدى معين
        Range("A5:J22").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
    
    'فتح ملف موجود على الجهاز
    Range("H23").Select
    Workbooks.Open Filename:="C:\Users\ashlolo\Documents\صفثان.xls"
    
    
    'اعداد الصفحة
    
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = "$A$1:$J$983"
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.393700787401575)
        .RightMargin = Application.InchesToPoints(0.393700787401575)
        .TopMargin = Application.InchesToPoints(0.393700787401575)
        .BottomMargin = Application.InchesToPoints(0.393700787401575)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
    End With
    

End Sub
Sub Macro2()
' Macro2 Macro
' Macro recorded 31/03/2014 by ashlolo
'جعل الناففذة ملء الشاشة
      Application.DisplayFullScreen = True
        'اغلاق شاشة ملء الشاشة
        Application.DisplayFullScreen = False
        'البحث عن نص ما داخل الشاشة
        Cells.Find(What:="enter", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase _
        :=True, SearchFormat:=False).Activate
                'قص بيانات معينة لمدى
         Range("B1:F6").Select
    Selection.Cut
    'لصق بيانات
    Range("I15").Select
    ActiveSheet.Paste
        'نسخ بيانات ولصقها
    Selection.Copy
    Range("I1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
        'اظهار الدوائر الحمراء
    Range("H3:H52").Select
    ActiveWindow.SmallScroll Down:=-23
    Range("H3:H52,J3,J3:J52").Select
    Range("J3").Activate
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _
        Formula1:="15"
    Selection.FormatConditions(1).Interior.ColorIndex = 22
        'مسح بيانات لمدى بيانات
        Cells.Select
    Selection.ShapeRange.Item(1).Hyperlink.Follow NewWindow:=False, AddHistory _
        :=True
    Range("G3:J6").Select
    Selection.ClearContents
    'اظهار المربع الحوارى لراس وتذييل الصفحة
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = "$A$1:$J$983"
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = "&P"
        .RightHeader = ""
        .LeftFooter = "الحمد لله"
        .CenterFooter = ""
        .RightFooter = "الله اكبر"
        .LeftMargin = Application.InchesToPoints(0.393700787401575)
        .RightMargin = Application.InchesToPoints(0.393700787401575)
        .TopMargin = Application.InchesToPoints(0.393700787401575)
        .BottomMargin = Application.InchesToPoints(0.393700787401575)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
           End With
    'لحذف الفواصل بين الصفحات
    ActiveSheet.VPageBreaks(1).Delete
   'لوضع كلمة سر للبرنامج
    Sheets("اختصارات").Select
    ActiveWorkbook.Password = "ashlolo111"
    'ترتيب النوافذ راسيا
    Range("B2:I13").Select
    Windows.Arrange ArrangeStyle:=xlTiled
    'ترتيب النوافذ افقيا
    ActiveWindow.WindowState = xlNormal
    ActiveWindow.WindowState = xlNormal
    Windows.Arrange ArrangeStyle:=xlHorizontal
    'لجعل نافذة واحدة هى النشطة
    ActiveWindow.WindowState = xlNormal
    ActiveWindow.WindowState = xlNormal
    ActiveWorkbook.Windows.Arrange ArrangeStyle:=xlTiled
    'لجعل اتجاة الورقة من اليسار لليمين
    ActiveWindow.WindowState = xlNormal
    ActiveWindow.WindowState = xlNormal
    ActiveSheet.DisplayRightToLeft = False
    'لجعل اتجاة الورقة من اليمين لليسار
    ActiveWindow.WindowState = xlNormal
    ActiveWindow.WindowState = xlNormal
    ActiveSheet.DisplayRightToLeft = True
    'لوضع حماية لورقة العمل
       ActiveWindow.WindowState = xlNormal
    ActiveWindow.WindowState = xlNormal
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    'لفك حماية ورقة العمل
    ActiveWindow.WindowState = xlNormal
    ActiveWindow.WindowState = xlNormal
    ActiveSheet.Unprotect
    'اخفاء شريط الصيغة اسم البرنامج فى شريط المهام
    ActiveWindow.WindowState = xlNormal
    ActiveWindow.WindowState = xlNormal
    With Application
        .DisplayFormulaBar = False
        .ShowWindowsInTaskbar = False
        End With
        'اخفاء شريط اوراق العمل
    ActiveWindow.DisplayWorkbookTabs = False
    'اخفاء شريط القوائم
    Range("G7").Select
    Application.CommandBars("Worksheet Menu Bar").Visible = False
    'اظهار جميع الاعمدةالمخفية
    Cells.Select
    Selection.EntireColumn.Hidden = False
    'بحث عن كلمة Enter داخل ورقة العمل
    Range("L19").Select
    Cells.Find(What:="enter", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
        True, SearchFormat:=False).Activate
        'مسح البيانات لمدى معين
    Range("G15:J21").Select
    Selection.ClearContents
    'اظهار شريط الصيغة
      ActiveWindow.View = xlNormalView
    Application.DisplayFormulaBar = True
    'اضافة مشغل الموسيقى
    ActiveSheet.OLEObjects.Add(ClassType:="WMPlayer.OCX.7", Link:=False, _
        DisplayAsIcon:=False).Select
    ActiveSheet.Shapes("WindowsMediaPlayer1").Select
    'حذف مشغل الموسيقى
        ActiveSheet.Shapes("WindowsMediaPlayer1").Select
    Selection.Delete
    'تكبير الشاشة
    ActiveWindow.WindowState = xlMaximized
    'تصغير الشاشة
    Application.WindowState = xlMinimized
    'استعادة الشاشة
    Application.WindowState = xlNormal
    '
End Sub

Sub Macro3()
'
' Macro3 Macro
' Macro recorded 31/03/2014 by ashlolo
'

' للخلية لوضع خليفة لون
    With Selection.Interior
        .ColorIndex = 3
        .Pattern = xlSolid
    End With
    'لازالة خليفة اللون على الخلية
    Range("O20").Select
    Selection.Interior.ColorIndex = xlNone
    'لوضع حدود للخلايا
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    'لدمج خليتين
    Range("N5:O5").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    '
    End Sub
    'لتوسيط النص فى الخلايا  و جعل اتجاة الكتابة من اليمين لليسار
    Cells.Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlRTL
        .MergeCells = False
    End With
    'لترتيب البيانات تصاعديا من اعلى لاسفل بناء على عمود معين وهو L
    Range("L2:O17").Select
    Selection.Sort Key1:=Range("L2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        'اظهار شريط الاوراق
    ActiveWindow.DisplayWorkbookTabs = True
    'زوم للشاشة
       ActiveWindow.Zoom = 200
       'زوم للشاشة
    ActiveWindow.Zoom = 100
    'جعل محتوى الخلية بزاوية 45
    Range("P7").Select
    ActiveCell.FormulaR1C1 = ""
    Range("O8").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 45
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlRTL
        .MergeCells = False
    End With
    'جعل الخلية الخط غامض
    Selection.Font.Bold = True
    'الخط عريض وحجمه 12
    Range("N9:P13").Select
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Arial"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    'لنسخ تنسيق نص ما وتنسيقه على نص ىخر
    Range("I17").Select
    Selection.Copy
    Range("O11:P15").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    'تعبئة تلقائية
       Range("M13").Select
    Selection.AutoFilter
    Range("B2:N11").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=13, Criteria1:="<15", Operator:=xlAnd
    ActiveSheet.ShowAllData
    Selection.AutoFilter
    Range("E2:L9").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=8, Criteria1:="<15", Operator:=xlAnd
    Selection.AutoFilter
    'انشاء ارتباط تشعبى لاكثر من صفحة
    ActiveSheet.Shapes("AutoShape 76").Select
    Selection.ShapeRange.Item(1).Hyperlink.SubAddress = "Sheet2!A1"
      Selection.ShapeRange.Item(1).Hyperlink.SubAddress = "Sheet4!A1"
 
    

Sub Macro4()
'
' Macro5 Macro
' Macro recorded 31/03/2014 by ashlolo
'

'مسح بيانات
    Range("G14:L20").Select
    Selection.ClearContents
    '
    Range("G2").Select
    ActiveSheet.Paste
End Sub

 

[محمد الورفلي1]

بارك الله فيك

[mada4top]

بارك الله فيك وجعله في ميزان حسناتك

[ابو بهاء المصري]

بارك الله فيك

[ياسر خليل أبو البراء]

الأخ الحبيب أشرف السيد

بارك الله فيك على حرصك لنشر ما تعلمته

يرجى تنظيم الموضوع بشكل يمكن الأعضاء من الاستفادة منه

الأكواد توضع بين أقواس الكود

راجع التوجيهات في الموضوعات المثبتة لمعرفة كيفية التعامل مع المنتدى

 

جزاك الله خير الجزاء

تقبل تحياتي

[Yasser Fathi Albanna]

 

 

[سـامي 169]

جزاك الله خيرا

لو وضعت كل كود بمرفق يوضح عمله

لكانت الفائده اعظم

[AYMAN Z HARB]

السلام عليكم 

اريد فتح ملف اكسيل نسيت كلمة سر فتح الملف 

كلمة سر فتح الملف وليست الحماية وليست الفيجوال 

وشكرا 

[هاشم بركات]

جزاك الله خيرا