اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

اشرف السيد

عضو جديد 01
 عرض الملف الشخصي  عرض المشاركات

  • Posts

    11

  • تاريخ الانضمام

  • تاريخ اخر زياره

 نوع المحتوي 

مشاركات المكتوبه بواسطه اشرف السيد

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

    في منتدى الاكسيل Excel

    قام بنشر

    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

     

    • Like 1

    ماكرو للبحث فى اكثر من صفحة

    في منتدى الاكسيل Excel

    قام بنشر

    ماكرو بحث

    Sub Test()
Dim sh As Worksheet
Dim Lr As Long
Dim i As Integer
Dim Name As String, Clon As String
            Set sh = ThisWorkbook.Sheets("Sheet1")
1    Clon = InputBox(prompt:="اختيار عمود البحث.", _          Title:="اختيار عمود", Default:="اكتب اسم العمود الذي تريد البح فيه هنا")                         If Clon Like "[A-z]" Then        Lr = sh.Cells(sh.Rows.Count, Clon).End(xlUp).Row        GoTo 2     Else        MsgBox " A-Z يجب ان تكون الحروف "        GoTo 1     End If     
     2    Name = InputBox(prompt:="ادخل الاسم او الرقم ", _          Title:=" بحث حسب العمود المختار", Default:="اكتب الاسم او الرقم الذي تبحث عنه هنا")
 For i = 1 To Lr 
  
If sh.Range(Clon & i) = Name Then  
      sh.Range(Clon & i).Select       
Exit For 
  
ElseIf i = Lr ThenMsgBox "الاسم الذي ادخلته غيرموجود"   
End If
Next 
End Sub

    ماكرو لاظهار اوراق العمل الموجودة الظاهرة وليس المخفية

    في منتدى الاكسيل Excel

    قام بنشر

    application.commandbars("workbook tabs").showpopup

    يتم وضع هذا الكود فى ماكرو ثماظهار شريط للماكرو ثم ضغطة يمين على ايقونة الماكرو واختيار assign Macro واختيار اسم الماكرو الذى انشائته ز

    فتظهر شريط باسماء الاوراق العمل على الشاشة ويتم اختيار اى ورقة او صفحة تريدها

     

     

     

    ولكن لها سلبية واحدة فقط وهى ان هذا الشريط يبقى مفتوح كلما فتحت اى ملف اكسيل مرة اخرى وعند الضغط عليه يقوم باستدعاء الشريط من البرنامج فيفتح الملف الاساسى

     

     

     

    توجد طريقة ثانية لاظهار اوراق العمل بالضغط على ازرار التحكم بزر الفارة الايمن فتظهر الاوراق

     

    ارجو ان اكون وفقت

    طلب تثبيت اعداد الصفحة

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم

    لتعديل هوامش الصفحة ونوع الورقة وحجمها

    ممكن من الريجسترىregistry وتدخل على software ثم الاوفيس ثم الاكسيل ثم .............

    ثم تعمل تصدير للملف لتحفظه بصغية reg

    ثم تضغط على الملف فيلزم الاكسيل فى بداية الفتح بالاعدادات التى غيرتها

     

×
×
  • اضف...

Important Information

  I accept