عمل تقرير وفلترة بعدة شروط

[moaaz2020]

السلام عليكم ورحمه الله وبركاته

احاول عمل ملف لتنظيم صرفيات العمال في المشاريع  ولكنني واجهت صعوبه في عمل بحث او فلتره للبيانات الموجودة في الملف Payments لخيار واحد او عدة خيارات مع بعض

مثلا البحث وفق اسم المستلم او المشروع او المستلم والمشروع مع بعض كما هو موجود في الملف المرفق

ولاحظت ان الملف ثقيل مع انه لايحتوي على داتا كثيره ولا يوجد فيه اي ماكرو 

واي شخص لديه اضافه يمكن ان يساعدني بها في الملف فليتفضل

تحياتي

حسابات المشاريع.xlsx

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

Payments!$B$1:$B$65536  كيف تريد ان لا يكون الملف ثقيلاُ وانت تستعمل في 6 صفجات في كل منها  حوالي 100 معادلة وكل معادلة تبحث في 65536 صف اي ما مجموعه  65556×100×6 = اكثر من 40 مليون معادلة (مضروبة بــ 2 لأن البرنامج يعطي نتيجتين لكل معادلة أو الجواب صجيجاً او فراغ اذا كانت النتيجة خطأ) و هكذا الاكسل يقوم بأكثر من 80 مليون عملية حسابية مع كل ضغطة زر من الكيبورد او نقرة من الماوس 

كل هذا بالاضافة الى التنسيقات التي تقوم لها من تلوين بألوان مختلفة يزيد من ثقل الملف على الرغم من قلة البيانات فيه

(الاكسل معذور في هذه الحالة)

خفف المعادلات من حيث عدد الصفوف (اجعلها مثلاُ 1500 بدل 65536)

[moaaz2020]

كثير منا تنقصه الخبره ويقوم بنقل الصفحات والمعادلات من ملفات جاهوه فقط ولذلك يقع في هذا الخطا ...

شكرا  لك لتنبيهي لاهميه هذا الامر وساحاول تعديله باذن الله

تحياتي لك

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

الملف يجب ان يكون هكذا (75 كيلو بايت لا أكثر)

Hisabat.xlsx

[moaaz2020]

هل يمكن ان يشمل البحث خيارات اخرى

كاسم المستلم مثلا او المستلم + المشروع معا

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

كاسم المستلم مثلا او المستلم + المشروع معا

لم أر  المستلم ولا المشروع في الجدول 

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

جرب هذا الملف (صفحة One For_All ) الملف مرفق 

Option Explicit

Dim DC As Object
Dim DD As Object
Dim D_Sh As Object
Dim O As Worksheet
Dim sh As Worksheet
Dim i, Max_ro%, m%
'++++++++++++++++++++++++++++++
Private Sub Worksheet_Activate()
data_val
End Sub
'++++++++++++++++++++++++++
Sub MY_choose()
Select Case Sheets("One For_All").Range("G2")
 Case "E": Filter_Only_E
 Case "D": Filter_Only_D
 Case "D+E": Filter_C_And_D
 Case Else: Exit Sub
End Select
End Sub

'++++++++++++++++++++
Sub data_val()

Set O = Sheets("One For_All")
Set DC = CreateObject("Scripting.Dictionary")
Set DD = CreateObject("Scripting.Dictionary")

Max_ro = Sheets("Payments").Cells(Rows.Count, 2).End(3).Row
For i = 2 To Max_ro
  DC(Sheets("Payments").Cells(i, "C").Value) = vbNullString
  DD(Sheets("Payments").Cells(i, "D").Value) = vbNullString
 Next
With O.Range("D2").Validation
 .Delete
 .Add 3, Formula1:=Join(DC.keys, ",")
End With
With O.Range("E2").Validation
 .Delete
 .Add 3, Formula1:=Join(DD.keys, ",")
End With
End Sub
'+++++++++++++++++++++++++++
Sub Filter_Only_E()
Set O = Sheets("One For_All")
If O.Range("C4").CurrentRegion.Rows.Count > 1 Then
  O.Range("C4").CurrentRegion.Offset(1). _
  Resize(O.Range("C4").CurrentRegion. _
  Rows.Count - 1).Clear
End If
Max_ro = Sheets("Payments").Cells(Rows.Count, 2).End(3).Row
m = 5
If O.Range("E2") = vbNullString Then Exit Sub
For i = 2 To Max_ro
 If Sheets("Payments").Cells(i, "D") = O.Range("E2") Then
  O.Cells(m, 3) = m - 4
  O.Cells(m, 4).Resize(, 5).Value = _
  Sheets("Payments").Cells(i, 2).Resize(, 5).Value
  m = m + 1
 End If
Next
If O.Range("C4").CurrentRegion.Rows.Count > 1 Then

 With O.Range("C4").CurrentRegion.Offset(1). _
   Resize(O.Range("C4").CurrentRegion.Rows.Count - 1)
     
  .Borders.LineStyle = 1
  .Font.Size = 14
  .Font.Bold = True
  .Interior.ColorIndex = 35
  .InsertIndent 1
  End With
  End If
End Sub
'+++++++++++++++++++++++++++++++++++
Sub Filter_Only_D()
Set O = Sheets("One For_All")
If O.Range("C4").CurrentRegion.Rows.Count > 1 Then
  O.Range("C4").CurrentRegion.Offset(1). _
  Resize(O.Range("C4").CurrentRegion. _
  Rows.Count - 1).Clear
End If
Max_ro = Sheets("Payments").Cells(Rows.Count, 2).End(3).Row
m = 5
If O.Range("D2") = vbNullString Then Exit Sub
For i = 2 To Max_ro
 If Sheets("Payments").Cells(i, "C") = O.Range("D2") Then
  O.Cells(m, 3) = m - 4
  O.Cells(m, 4).Resize(, 5).Value = _
  Sheets("Payments").Cells(i, 2).Resize(, 5).Value
  m = m + 1
 End If
Next
If O.Range("C4").CurrentRegion.Rows.Count > 1 Then

 With O.Range("C4").CurrentRegion.Offset(1). _
   Resize(O.Range("C4").CurrentRegion.Rows.Count - 1)
     
  .Borders.LineStyle = 1
  .Font.Size = 14
  .Font.Bold = True
  .Interior.ColorIndex = 35
  .InsertIndent 1
  End With
  End If
End Sub
'++++++++++++++++++++
Sub Filter_C_And_D()
Set O = Sheets("One For_All")
If O.Range("C4").CurrentRegion.Rows.Count > 1 Then
  O.Range("C4").CurrentRegion.Offset(1). _
  Resize(O.Range("C4").CurrentRegion. _
  Rows.Count - 1).Clear
End If
Max_ro = Sheets("Payments").Cells(Rows.Count, 2).End(3).Row
m = 5
If O.Range("D2") = vbNullString Or _
  O.Range("E2") = vbNullString Then Exit Sub
For i = 2 To Max_ro
 If Sheets("Payments").Cells(i, "C") = O.Range("D2") And _
    Sheets("Payments").Cells(i, "D") = O.Range("E2") Then
  O.Cells(m, 3) = m - 4
  O.Cells(m, 4).Resize(, 5).Value = _
  Sheets("Payments").Cells(i, 2).Resize(, 5).Value
  m = m + 1
 End If
Next
If O.Range("C4").CurrentRegion.Rows.Count > 1 Then

 With O.Range("C4").CurrentRegion.Offset(1). _
   Resize(O.Range("C4").CurrentRegion.Rows.Count - 1)
     
  .Borders.LineStyle = 1
  .Font.Size = 14
  .Font.Bold = True
  .Interior.ColorIndex = 35
  .InsertIndent 1
  End With
  End If
End Sub

 

Hisabat_Super.xlsm

[moaaz2020]

نعم هذا  هو المطلوب

جزاك الله خير الثواب