عمل قائمة حساب حسب رقم السيارة

[محمد لؤي]

السلام عليكم : حياكم الله

ممكن عمل قائمة حساب حسب رقم السيارة وكما مبين بالملف المرفق المبينة فيه النتائج المطلوبة مع العلم بان ارقام السيارات لا تأتي متسلسلة فمرة يأتي رقم السيارة تسلسل 1 و 16 و 105 و 1000

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

قائمة حساب.rar

قائمة حساب.rar

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

تم معالجة القسم الاكبر من المطلوب

بقيت عملية الحسابات (فيما بعد لضيق الوقت)

نم تغيير اسم الصغحات لحسن العمل مع اللغة الاجنبية

 

قائمة حساب salim.rar

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

تم التعدبل على الملف للحصول على المجاميع

 

قائمة حساب salim with sum.rar

الكود مرفق

Sub filter_me()
Dim S_sh, T_sh As Worksheet
Dim X, Y, Z As Long
Dim LRSS, LRS, M As Integer
Dim T1, T2, T3 As String

Set S_sh = Sheets("Data"): Set T_sh = Sheets("Salim")
LRS = S_sh.Cells(Rows.Count, "e").End(3).Row
T_sh.Range("a1:H500").Clear
Range("e2:e" & LRS).Copy Range("S1")
Range("s1:s" & LRS).RemoveDuplicates Columns:=1, Header:=xlNo
LRSS = S_sh.Cells(Rows.Count, "s").End(3).Row
M = 1
 For i = 1 To LRSS
             T_sh.Range("j2").Formula = "=Data!E2=Data!$S$" & i
            Sheets("Data").Range("A1:H" & LRS).AdvancedFilter Action:=xlFilterCopy, _
             CriteriaRange:=Range("J1:J2"), CopyToRange:=Range("A" & M), Unique:=False
  On Error Resume Next
             M = M + Application.CountIf(S_sh.Range("e2:e" & LRS), S_sh.Range("s" & i)) + 2
            
               T1 = "=G" & M - 4 & "*VLOOKUP(H" & M - 4 & ",$M$2:$N$4,2,0)"
               If IsNumeric(Evaluate(T1)) Then X = Evaluate(T1) Else X = 0
              
                T2 = "=G" & M - 3 & "*VLOOKUP(H" & M - 3 & ",$M$2:$N$4,2,0)"
               If IsNumeric(Evaluate(T2)) Then Y = Evaluate(T2) Else Y = 0
               
                T3 = "=G" & M - 2 & "*VLOOKUP(H" & M - 2 & ",$M$2:$N$4,2,0)"
                If IsNumeric(Evaluate(T3)) Then Z = Evaluate(T3) Else Z = 0
            Cells(M - 1, 8) = "The sum:"
            Cells(M - 1, 7) = X + Y + Z
            
    Next
    S_sh.Range("s:s").Clear
    End Sub

 

تم تعديل مارس 21, 2017 بواسطه سليم حاصبيا

[محمد لؤي]

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

اود بيان الآتي :

بعد ادخال البيانات ظهرت النتائج المبينة بالملف المرفق ( تم حذف النتائج وأبقيت بعضها للتوضيح )

جزيت خيرا

قائمة حساب salim with sum.rar

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

5 ساعات مضت, محمد لؤي said:

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

اود بيان الآتي :

بعد ادخال البيانات ظهرت النتائج المبينة بالملف المرفق ( تم حذف النتائج وأبقيت بعضها للتوضيح )

جزيت خيرا

قائمة حساب salim with sum.rar

استعمل مؤقتاً الماكرو الموجود في المشاركة الاولى (مع تعديل عدد الصفوف من 500 الى 150000)

قائمة حساب salim.rar ريثما نجد حلاً للمجاميع

تم تعديل مارس 22, 2017 بواسطه سليم حاصبيا

[محمد لؤي]

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

 

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

تم معالجة الامر مع المجاميع و زيادة حبتين

 

قائمة حساب salim with summution.rar

الماكرو المطلوب

Option Explicit

Sub filter_me()
Dim S_sh, T_sh As Worksheet
Dim My_rg  As Range
Dim T2, T3, T4 As String
Dim VaL2, VaL3, VaL4, x, y, Z As Double
Dim Lrs, Lrss, LrSalim As Long
Dim m, k, i As Integer

If ActiveSheet.Name <> "Salim" Then GoTo ExitSub

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

 On Error GoTo ExitSub
Set S_sh = Sheets("Data"): Set T_sh = Sheets("Salim")
Lrs = S_sh.Cells(Rows.Count, "e").End(3).Row
T_sh.Range("a1:H150000").Clear
Range("e2:e" & Lrs).Copy Range("S1")
Range("s1:s" & Lrs).RemoveDuplicates Columns:=1, Header:=xlNo
Lrss = S_sh.Cells(Rows.Count, "s").End(3).Row
m = 1
 For i = 1 To Lrss
  T_sh.Range("j2").Formula = "=Data!E2=Data!$S$" & i

       Sheets("Data").Range("A1:H" & Lrs).AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("J1:J2"), CopyToRange:=Range("A" & m), Unique:=False

       m = m + Application.CountIf(S_sh.Range("e2:e" & Lrs), S_sh.Range("s" & i)) + 2
        Next
        LrSalim = T_sh.Cells(Rows.Count, "g").End(3).Row
     Set My_rg = T_sh.Range("g2:g" & LrSalim).SpecialCells(2, 1)
     For k = 1 To My_rg.Areas.Count
     My_rg.Areas(k).Select
     '======================================
     On Error Resume Next
      With My_rg.Areas(k)
x = .Cells(1).Row
y = .Rows.Count
Z = x + y

T2 = "SUMIFS($G$" & x & ":$G$" & Z - 1 & ",$H$" & x & ":$H$" & Z - 1 & "," & "$M$2" & ")*VLOOKUP($M$2,$M$2:$N$4,2,0)"
T3 = "SUMIFS($G$" & x & ":$G$" & Z - 1 & ",$H$" & x & ":$H$" & Z - 1 & "," & "$M$3" & ")*VLOOKUP($M$3,$M$2:$N$4,2,0)"
T4 = "SUMIFS($G$" & x & ":$G$" & Z - 1 & ",$H$" & x & ":$H$" & Z - 1 & "," & "$M$4" & ")*VLOOKUP($M$4,$M$2:$N$4,2,0)"

If Not (IsEmpty(Evaluate(T2))) Then VaL2 = Evaluate(T2) Else VaL2 = 0
If Not (IsEmpty(Evaluate(T3))) Then VaL3 = Evaluate(T3) Else VaL3 = 0
If Not (IsEmpty(Evaluate(T4))) Then VaL4 = Evaluate(T4) Else VaL4 = 0

Cells(Z, "g") = VaL2 + VaL3 + VaL4
Cells(Z, "H") = "Sum:"
   End With
       Next
       Cells(LrSalim + 1, "d") = "Total Sum:": Cells(LrSalim + 1, "d").Interior.ColorIndex = 35
       Cells(LrSalim + 1, "c").Formula = "=SUMPRODUCT(--($E$2:$E$100000=""""),$G$2:$G$100000)"
       Cells(LrSalim + 1, "c").Interior.ColorIndex = 35
ExitSub:
     Range("a1").Select
      Application.ScreenUpdating = True
      Application.Calculation = xlCalculationAutomatic
    End Sub

 

تم تعديل مارس 22, 2017 بواسطه سليم حاصبيا

[محمد لؤي]

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

حياك الله استاذ

جزيت خيرا - جزيت خيرا - جزيت خيرا

تمام

ومشكور على جدول المقارنة - كانت هي الخطوة الثاني - ولكن سبقت طلبي - جزيت خيرا

استاذ - امر واحد - عند ادخال البيانات والضغط على الزر لم ينفذ الماكرو ، (إلا) بعد نسخ ارقام السيارات وعمل فلترة عليها لازالة المكرر ونسخها في خانة (S) عندها تم تنفيذ الماكرو

الله يبارك في عمرك ووقتك - 

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

2 ساعات مضت, محمد لؤي said:

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

حياك الله استاذ

جزيت خيرا - جزيت خيرا - جزيت خيرا

تمام

ومشكور على جدول المقارنة - كانت هي الخطوة الثاني - ولكن سبقت طلبي - جزيت خيرا

استاذ - امر واحد - عند ادخال البيانات والضغط على الزر لم ينفذ الماكرو ، (إلا) بعد نسخ ارقام السيارات وعمل فلترة عليها لازالة المكرر ونسخها في خانة (S) عندها تم تنفيذ الماكرو

الله يبارك في عمرك ووقتك - 

امسح محتويات العامود S كاملة 

اضف هذا السطر الى الكود مباشرة بعد عبارة :Exitsub على سطر مستقل ثم تفذ الماكرو

 

S_sh.Range("s:s").Clear

 

[محمد لؤي]

تسلم استاذ 

جزيت خيرا