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

استخدام الوظائف الاضافيه

الـعيدروس

بواسطه الـعيدروس
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

الـعيدروس

الـعيدروس

قام بنشر
قام بنشر

 

السلام عليكم

 اضن الكثير منا يعلم ماهي الوظائف الإضافيه في الاكسل

  ومدى اهميتها في اختصار الكثير من الوقت للعمل على روتين معين لأكثر من مصنف

انا سأطرح لكم الفكرة والتطبيق والاليه التي استخدمت بها تلك الوظيفه الإضافية

 

أولاً ماهي الوظائف الإضافيه ؟

كخطوة اولى: توضيح وحفظ الوظيفه

- هيا عباره عن ملف اكسل به اكواد او فورم او داله ويحفظ بصيغة "Excel Add-In"

في المسار "AppData\Roaming\Microsoft\AddIns" او في اي مجلد تريد يكون

موقع له 

فرضاً سميناها "Aosamh"

وعند الحاجه لتلك الوظيفه تقوم بتفعيل الوظيفه كي تستخدمها للملف الذي تعمل عليه

الخطوة الثانية: تفعيل الوظيفه ( بعد ان حفظتها بالخطوة الاولى )

-من خيارات الاكسل - الوظائف الإضافية - إدارة الوظائف الإظافيه Excel ( تضغط زر المسمى "إنتقال" )

ومن ثم تحفز الوظيفه .

 

 

الفكرة كالتالي :

 تقرير مخزون عبر برنامج محاسبي

   اصدره الى الاكسل واقوم بعمل بعض التنسيقات والتعديلات عليه بشكل اتوماتيك

       واستخرج منه اعمدة معينه للعمل عليها 

       غرضي من هذه الطريقة عمل " تقرير لأصناف معينه لعمل خصم عليها بطريقة يدويه"

        خصم يدخل يدوي

         ومن ثم اجمالي الفارق بين سعر التكلفه القديم وسعر التكلفه الجديد واجمالي الفارق لكل الاصناف

             في نهاية التقرير

 

 ماتطلب علي استخدامة لأنجز تلك الفكره :

1- تصدير التقرير من البرنامج المحاسبي 

2- معرفة بعض الكلمات الاساسيه في التقرير المستخرج من البرنامج المحاسبي ( لمعرفة ان الملف هو مانريده كي نفعل عليه الوظيفة الاضافية)

3- عمل بعض التعديلات على الملف من الغاء دمج بعض الخلايا وحذف بعض الاعمدة التي لااستخدمها للغرض الذي اريده

 وماسبق ذكرة الـ 3 البنود منها عملتها بظريقه يدوية ومن ثم بالكود كي يقوم بما عملته عند استدعائي للوظيفة ( 2 و 3 )

4- عمل في بعض الاعمدة معادلات عبر الكود ومنها اجمالي التقرير بعد اضافة القيم اليدويه

5- انشاء فورم بحث للبحث عن الاصناف في التقرير سواء برقم الصنف او مرجعه

 

الاكواد المستخدمة في ملف الوظيفة الإضافية  كالتالي :

 

1- كود حدث فتح ملف الاكسل "Auto_Open"

-استخدمناه لكي نفعل كود التحقق من ان الملف المفتوح حالياً هو مانريده "تقرير المخزون" ام لا

     الكود في حدث فتح المصنف بعد 3 ثواني من فتح المصنف ينفذ الكود المسمى "Action_Abad" 

Sub Auto_Open()
   Application.OnTime Now + TimeValue("00:00:03"), "Action_Abad"
End Sub

 هذا كود "Action_Abad" يقوم بتنفيذ الدالة "Check_Work" واذا كان نتيجة الدالة True يعني هو الملف المطلوب

دالة "Check_Work" تقوم بالبحث في المصنف هل يوجد كلمة "تقييم المخزون" اذا تحقق الشرط تقوم بالتالي  

Public Const Trgt As String = "تقييم المخزون"
Public Function Check_Work()
Dim Rng_Chk
For Each Rng_Chk In ActiveWorkbook.ActiveSheet.UsedRange.Cells
  If Trim(Rng_Chk) Like Trgt Then
      Bl_Open = True
    Exit Function
  End If
Next
End Function

 

تقوم بإنشاء زر اختصار للكود "Ali_Tk" في تبويب الوظائف الاضافية  

Sub Action_Abad()
'===============
  Check_Work '' دالة التحقق من الملف المفتوح حالياً
'===============
If Bl_Open = True Then
Dim cb As CommandBar
Dim ctrl As CommandBarControl
 On Error Resume Next
   Application.CommandBars("Tol_Abad").Delete
 On Error GoTo 0
Set cb = Application.CommandBars.Add(Name:="Tol_Abad")
With cb
    .Visible = True
    .Position = msoBarTop
  Set ctrl = .Controls.Add(Type:=msoControlButton)
With ctrl
   .BeginGroup = True
     .Style = msoButtonIconAndCaption
     .Caption = "تقرير_خصم"
     .FaceId = 107
     .OnAction = "Ali_Tk" '' الزر يقوم بتشغيل كود عمل التنسيقات وحذف اعمدة من تقرير المخزون
   .TooltipText = "تقرير خصم لأصناف"
End With
End With
Bl_Open = False
End If
End Sub

وهذا كود "Ali_Tk" الذي يقوم بعمل تنسيقات للتقرير واضافة اعمدة ودوال واستخراج الاعمدة الاساسية في مصفوفة "Arr" 

Sub Ali_Tk()
Dim Arr
Dim RR, Mord, On_Rw
Dim Rm As Range
Dim Rnn As Range, Rmm As Range
Dim Rng As Range
A_Application False
ActiveWorkbook.ActiveSheet.UsedRange.UnMerge
Arr = Array("تقييم المخزون", "‏المورد :‏", "‏م‏", "‏رقم الصنف‏", "‏وصف الصنف‏", "‏رقم المرجع‏", "‏إجمالي الكمية‏", "‏السعر‏")
For Each RR In ActiveWorkbook.ActiveSheet.UsedRange.Cells
 For Each Ar In Arr
   If Trim(RR) Like Trim(Ar) Then
      Select Case Trim(RR)
             Case Is = Arr(0)
             Case Is = Arr(1)
                RR.Select
                Lrm = Selection.End(xlToLeft).Column '' إيجاد عمود اسم المورد
                Mord = CStr(S_Nm_Ali(Cells(RR.Row, Lrm)))      '' إســم المورد
                On_Rw = RR.Row                '' أول صف للجدول
             Case Else
                If Not RR Is Nothing Then
                   If Rm Is Nothing Then
                        Set Rm = RR
                     Else
                        Set Rm = Union(Rm, RR)
                   End If
               End If
     End Select
   End If
 Next
Next
     Rm.EntireColumn.Hidden = True
       Set Rng = Range("A1:AB1")
'*************************************************************
      Rng.SpecialCells(xlCellTypeVisible).EntireColumn.Delete
      Range("A1:A" & On_Rw).EntireRow.Delete
      ActiveSheet.UsedRange.EntireColumn.Hidden = False
'*************************************************************
      Range("A:A,B:B").Select
      Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'*************************************************************
      Rows("1:1").RowHeight = 40
      Rows("2:2").RowHeight = 28.5
      Range("C2") = "تكلفة جديدة"
      Range("A2") = "الفرق"
     ActiveSheet.UsedRange.EntireColumn.AutoFit
    Columns("F:F").ColumnWidth = 11
    Columns("E:E").ColumnWidth = 9.14
    Columns("G:G").ColumnWidth = 7.57
    Columns("G:G").ColumnWidth = 11.57
    Columns("G:G").ColumnWidth = 10.71
    R = 3
    Lr = Cells(Rows.Count, 2).End(xlUp).Row
     For i = R To Lr
          Cells(i, 1).Formula = "=IF(RC[2]="""","""",CEILING(IF(RC[2]="""","""",(RC[3]*RC[1])-(RC[3]*RC[2])),1))"
     Next
     With Range("A" & Lr + 1)
         .Formula = "=SUBTOTAL(9," & Range("A3:A" & Lr).Address(0, 0) & ")"
         .Offset(0, 1).Formula = "=SUBTOTAL(9," & Range("B3:B" & Lr).Address(0, 0) & ")"
         .Offset(0, 2).Formula = "=SUBTOTAL(9," & Range("C3:C" & Lr).Address(0, 0) & ")"
         .Offset(0, 3).Formula = "=SUBTOTAL(9," & Range("D3:D" & Lr).Address(0, 0) & ")"
     End With
     Range(Cells(3, 1), Cells(Lr + 1, 8)).Borders.Color = 1
     Range(Cells(3, 1), Cells(Lr + 1, 8)).RowHeight = 24.75
     Range(Cells(3, 1), Cells(Lr + 1, 8)).WrapText = False
     Columns("A:H").AutoFit
     Columns("A:D").ColumnWidth = 9
     With Range(Cells(3, 1), Cells(Lr + 1, 8))
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .Interior.ColorIndex = xlNone
        With Range("A" & Lr + 1 & ":H" & Lr + 1)
          .Interior.Color = RGB(252, 228, 214)
          .Font.ColorIndex = 23
          .Font.Bold = True
         .HorizontalAlignment = xlCenter
         .VerticalAlignment = xlCenter
        End With
        With Range("A2:H2")
          .Interior.Color = RGB(252, 228, 214)
          .Offset(-1, 0).Merge
          .Offset(-1, 0).RowHeight = 40
          .Font.ColorIndex = 23
          .Font.Bold = True
          .Borders.Color = 0
         .HorizontalAlignment = xlCenter
         .VerticalAlignment = xlTop
        End With
      End With
    With ActiveSheet.PageSetup
        .PrintArea = Range(Cells(1, 1), Cells(Lr + 1, 8)).Address
        .PrintTitleRows = "$1:$2"
        .PrintTitleColumns = ""
        .Zoom = 123
        .LeftMargin = Application.InchesToPoints(3.93700787401575E-02)
        .RightMargin = Application.InchesToPoints(3.93700787401575E-02)
        .TopMargin = Application.InchesToPoints(3.93700787401575E-02)
        .BottomMargin = Application.InchesToPoints(3.93700787401575E-02)
        .HeaderMargin = Application.InchesToPoints(3.93700787401575E-02)
        .FooterMargin = Application.InchesToPoints(3.93700787401575E-02)
        .CenterHorizontally = True
        .CenterVertically = False
    End With
    Range("A3").Select
    ActiveWindow.FreezePanes = True
    ActiveWindow.SmallScroll Down:=12
    Range("C3").Select
    With Range("A1")
      .Value = "(" & " طلب خصم بضاعة / " & Mord & " / للمؤسسة  " & ")"
       .Font.Name = "Times New Roman"
       .Font.Size = 14
       .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
'=====================
    Action_Search ''  إستدعاء كود إضافة زر اخر في تبويب الوظائف الإضافية _
                      لإنشاء زر في تبويب الوظائف الإضافية واسمه بحث ليقوم بتنفيذ كود فتح فورم البحث والتعديل
'=====================
A_Application True
End Sub

   وفي نهاية الكود يستدعي الكود "Action_Search" ليضيف زر اخر في تبويب الوظائف الإضافية واسمه "بحث" لينفذ  كود فتح " فورم البحث"

          

Private Sub Action_Search()
Dim cb As CommandBar
Dim ctrl1 As CommandBarControl
Set cb = Application.CommandBars("Tol_Abad")
With cb
.Position = msoBarTop
   Set ctrl1 = .Controls.Add(Type:=msoControlButton)
    With ctrl1
       .BeginGroup = True
         .Style = msoButtonIconAndCaption
          .Caption = "بحث"
          .FaceId = 1100
        .OnAction = "Show_Ali"
      .TooltipText = " بحث في بيانات الاصناف للمورد"
    End With
End With
'======================
 Visbl_Control False '' الذي يقوم بعمل تنسيقات تلافياً لعدم الضغط عليه مره اخرى ' إخفاء زر المسمى تقرير_خصم
 '==============
 Action_Prnt  '' إستدعاء كود لإضافة زر اخر بإسم طباعه لينفذ كود طباعة التقرير بعد الانتهاء من عمل التعديلات عليه
 '=============
End Sub

دالة " Visbl_Control" لتقوم بإخفاء زر " تقرير_خصم " تلافياً لعدم الضغط عليه مره اخرى  

Function Visbl_Control(Vis As Boolean)
   Application.CommandBars("Tol_Abad").Controls("تقرير_خصم").Visible = Vis
End Function

 

 كود فتح فورم البحث المسمى " Show_Ali" 

Sub Show_Ali()
  Ali_Search.show 0
End Sub

وفي نهاية كود "Action_Search" يستدعي كود المسمى "Action_Prnt" ليقوم بإنشاء زر واسمه "طباعه" 

  لينفذ الكود المسمى "Prnt" 

Private Sub Action_Prnt()
Dim cb As CommandBar
Dim C As CommandBarControl
Set cb = Application.CommandBars("Tol_Abad")
With cb
    .Position = msoBarTop
      Set C = .Controls.Add(Type:=msoControlButton)
        With C
          .BeginGroup = True
             .Style = msoButtonIconAndCaption
            .Caption = "طباعه"
            .FaceId = 180
            .OnAction = "Prnt"
         .TooltipText = " طباعة النتائج "
        End With
End With
End Sub

وهذا كود الطباعه  المسمى "  Prnt" ليطبع التقرير بعد عمل التصفية للصفوف الملونه بلون معين 

Sub Prnt()
With ActiveSheet
    .Range("A2:H2").Select
    Selection.AutoFilter
    Ln = .Cells(.Rows.Count, 2).End(xlUp).Row
        .Range(Cells(2, 1), Cells(Ln, 8)).AutoFilter Field:=6, Criteria1:=RGB(225, 225, 235), Operator:=xlFilterCellColor
             If .UsedRange.SpecialCells(xlCellTypeVisible).Count <= 24 Then
              MsgBox "لايوجد نتائج للطباعه", vbInformation, ""
             .Range("A2:H2").Select
                Selection.AutoFilter
        Exit Sub
    End If
     .Range("G2").EntireColumn.Hidden = True
       .PrintPreview
         .Range("G2").EntireColumn.Hidden = False
        .Range("A2:H2").Select
        Selection.AutoFilter
    .Range("A2").Select
End With
End Sub

وهذا كود حدث اغلاق المصنف " Auto_close "ليقوم بحذف تبويب الوظائف الإضافية بما فيه من ازرار انشأناها وقت الاستخدام

  

Sub Auto_close()
On Error Resume Next
Application.CommandBars("Tol_Abad").Delete
Application.CommandBars("Benefits Survey Toolbar").Delete
On Error GoTo 0
End Sub

 

ماأرجوه من طرحي هذا اخذ فكره عن الوظائف الإضافية وبما يمكنها من استخدام اكواد ومعادلات مستحدثه في اكثر من ملف

وقت الاستخدام وافكار ان شاء الله يستفاد منها

- مرفق ملف شرح فيديو طريقة العمل 

-  وملف التقرير  المستخرج من البرنامج المحاسبي

- وملف الاكواد والفورم وهو كوظيفة إضافية 

 

لم استطيع ارفاق الملفات حملتها عبر 4Share وهذا رابط المرفقات

http://www.4shared.com/rar/x33ci575ba/_online.html

 

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

 

  • Like 7
  • Thanks 1
رابط هذا التعليق
شارك
Yasser Fathi Albanna

Yasser Fathi Albanna

قام بنشر
قام بنشر

سلمت يمينك أخى أستاذى ومعلمى القدير / العيدروس

زادك الله من العلم الكثير والكثير وأدام عليك الصحة والعافية وجعله فى ميزان حسناتك

تقبل خالص تحياتى وتقديرى

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept