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

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


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

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

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

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

قائمة حساب.rar

قائمة حساب.rar

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

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

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

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

 

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

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

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

 

قائمة حساب 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

 

تم تعديل بواسطه سليم حاصبيا
  • Like 1
رابط هذا التعليق
شارك

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

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

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

جزيت خيرا

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

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

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

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

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

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

جزيت خيرا

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

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

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

تم تعديل بواسطه سليم حاصبيا
  • Like 1
رابط هذا التعليق
شارك

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

 

قائمة حساب 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

 

تم تعديل بواسطه سليم حاصبيا
  • Like 1
رابط هذا التعليق
شارك

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

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

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

تمام

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

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

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

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

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

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

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

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

تمام

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

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

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

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

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

 

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

 

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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

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

Important Information