عمل بودرة حسابية لكل منتسب

[خالد ابوعوف]

حياكم الله

عمل بودرة حسابية لكل منتسب تجمع بها الرواتب والمكافات وبدل الطعام والنقل وخصم مبلغ الغياب

والمبلغ المستحق للمنتسب

واذا (امكن) وضع آلية بالكود لجمع الخانات المطلوب جمعها ( أي في حالة اضافة حقول اخرى المطلوب جمعها) حتى يمكنني التعديل على الكود في حالة الاضافة

 

عمل بودرة للمنتسب.rar

تم تعديل فبراير 6, 2019 بواسطه خالد ابوعوف

[سليم حاصبيا]

جرب هذا الماكرو 

 (لا أعلم لماذا هذا الحجم اكثر للملف اكثر من 4 ميفا)

Option Explicit

Sub FiND_DATA()
Dim i%: i = 2
Dim arr, k%: k = 1
Dim H%
Dim rg As Object
Dim My_Table As Range: Set My_Table = Sijjel.Range("d1:m100")
Salim.Cells.Clear
Set rg = CreateObject("system.collections.arraylist")
With rg
 Do Until Sijjel.Range("F" & i) = vbNullString
  If Not .contains(Sijjel.Range("f" & i).Value) And _
   Application.CountIf(Sijjel.Range("F2:f" & i), Sijjel.Range("F" & i)) = 1 Then
   .Add Sijjel.Range("F" & i).Value
   End If
 i = i + 1
  Loop


Salim.Range("q1").Formula = "اسم المنتسب"
 '====================
For i = 0 To rg.Count - 1
Salim.Range("q2") = rg.Item(i)
My_Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Salim.Range("Q1:q2"), _
CopyToRange:=Salim.Range("A" & k)
H = Salim.Cells(Rows.Count, 1).End(3).Row
k = H + 3
Next
 End With
 Salim.Range("q1:q2") = vbNullString
End Sub

الملف مرفق صفحة   Salim

عملSALIM.xlsm

[خالد ابوعوف]

حياكم الله - الاخ الاستاذ سليم

العمل ممتاز - جزاك الله خيرا

ولكن المجموع ضروري - وفقك الله

ممكن استاذنا عمل المجاميع كما موجود في شيت البودرة

شاكر جهودك 

تم تعديل فبراير 6, 2019 بواسطه خالد ابوعوف

[سليم حاصبيا]

لك ما تريد _(تم تبديل الملف لان جحمه كبير جداً مما يعيق تنفيذ الماكرو)

الكودين

Option Explicit


Sub FiND_DATA()
Dim i%: i = 2
Dim arr, k%: k = 1
Dim H%
Dim rg As Object
Dim My_Table As Range: Set My_Table = Sijjel.Range("a1:L100")
Salim.Cells.Clear
Set rg = CreateObject("system.collections.arraylist")
With rg
 Do Until Sijjel.Range("E" & i) = vbNullString
  If Not .contains(Sijjel.Range("E" & i).Value) And _
   Application.CountIf(Sijjel.Range("E2:E" & i), Sijjel.Range("E" & i)) = 1 Then
   .Add Sijjel.Range("E" & i).Value
   End If
 i = i + 1
  Loop

Salim.Range("q1").Formula = "اسم المنتسب"
 '====================
For i = 0 To rg.Count - 1
Salim.Range("q2") = rg.Item(i)
My_Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Salim.Range("Q1:q2"), _
CopyToRange:=Salim.Range("A" & k)
H = Salim.Cells(Rows.Count, 5).End(3).Row
k = H + 3
Next
 End With
 Salim.Range("q1:q2") = vbNullString
 Find_emPty
End Sub
''''''''''''''''''''''''''''''''''''''''
Sub Find_emPty()
Dim lre%: lre = Salim.Cells(Rows.Count, "E").End(3).Row
Dim arr1(), arr2()
Dim i%, k%: k = 1
'Dim m%: m = 2
For i = 2 To lre
 If Salim.Cells(i, "e") = vbNullString Then
  ReDim Preserve arr1(1 To k): arr1(k) = Salim.Cells(i, "e").Row
  k = k + 1
  i = i + 1
 End If
 Next
 '======================================
 Dim rg As Range
Dim txt$
Dim f_addres$
txt = "اسم المنتسب"
Dim m%: m = 1
Dim x
 x = Salim.Cells(Rows.Count, "E").End(3).Row
Set rg = Range("E1:e" & x).Find(txt, after:=Cells(x, 5), LookIn:=xlValues, lookat:=xlPart)
 If Not rg Is Nothing Then
  f_addres = rg.Row + 1
  Do
   ReDim Preserve arr2(1 To m): arr2(m) = rg.Row + 1
   m = m + 1
   If m > x - 1 Then Exit Do
   Set rg = Range("E1:e" & x).FindNext(rg)
  Loop While rg.Row + 1 > f_addres
  Else
 
 End If
  ReDim Preserve arr1(1 To UBound(arr1) + 1)
   arr1(UBound(arr1)) = x + 1
 For i = 1 To UBound(arr2)
 
  Cells(arr1(i), 1).Resize(, 12).Interior.ColorIndex = 6
  Cells(arr1(i), 6) = Application.Sum(Range(Cells(arr2(i), 6), Cells(arr1(i) - 1, 6)))
  Cells(arr1(i), 7) = Application.Sum(Range(Cells(arr2(i), 7), Cells(arr1(i) - 1, 7)))
  Cells(arr1(i), 8) = Application.Sum(Range(Cells(arr2(i), 8), Cells(arr1(i) - 1, 8)))
  Cells(arr1(i), 9) = Application.Sum(Range(Cells(arr2(i), 9), Cells(arr1(i) - 1, 9)))
  Cells(arr1(i), 10) = Application.Sum(Range(Cells(arr2(i), 10), Cells(arr1(i) - 1, 10)))
  Cells(arr1(i), 11) = Application.Sum(Range(Cells(arr2(i), 11), Cells(arr1(i) - 1, 11)))
  Cells(arr1(i), 12) = Application.Sum(Range(Cells(arr1(i), 6), Cells(arr1(i), 11)))
 Next
 
 '==================================

End Sub
'=============================

الملف مرفق

 

Badil.xlsm

[خالد ابوعوف]

حياك الله - الاستاذ العزيز - سليم

جزيت خيرا - حلت كل الأمور كلها - اللهم وفق الاستاذ ورزقه العلم وبارك له

ملاحظة : مسالة المبلغ (الصافي) يجب (طرح) مبلغ الغياب  وليس الجمع 

فقط هذه ويصبح العمل 100 %

 

[سليم حاصبيا]

تمت معالجة الامر (مع الترتيب الأبجدي للاسماء)

 

Badil (1).xlsm

[خالد ابوعوف]

حياك الله - جزيت خيرا

هو المطلوب