إظهار نتائج في ليست بوكس حسب الكمبوبكس

[sof17]

السلام عليكم 

أريد حساب عدد الفواتير حسب الكمبوبكس في الفورم مع إعطاء المجاميع و العدد  شرح موجود في الملف وشكرا مقدما

تجربة.xlsm

[محمد هشام.]

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

Dim F, Rng, Col, width, j, Total()
Private Sub UserForm_Initialize()

Dim WS As Worksheet: Set WS = Sheets("data")
  Set d = CreateObject("scripting.dictionary")
  Set F = WS.Range("A2:E" & WS.[C65000].End(xlUp).Row)
  
  Rng = F.Value
  Col = Array(5, 4, 3, 2, 1)
  width = Array(100, 100, 100, 100, 100)
  For i = LBound(Rng) To UBound(Rng): Rng(i, 5) = Format(Rng(i, 5), "#,##00.00"): Next i
  Me.Ls_ATA.ColumnCount = UBound(Col) + 1
  Me.Ls_ATA.ColumnWidths = Join(width, ";")
  
    Me.Ls_ATA.List = Application.Index(F, Evaluate("Row(1:" & F.Rows.Count & ")"), Col)
    Total = Array(5, 4, 3, 2, 1): j = UBound(Total) + 1
  d("*") = ""
  For i = 1 To UBound(Rng)
    d(Rng(i, 4)) = ""
  Next i
  r = d.keys
  Me.T1.List = r: Me.T1 = "*"
  MySum
End Sub
'*********************
Private Sub T1_click()
  Dim Tbl(): n = 0: Clé = Val(Me.T1)
  For i = 1 To UBound(Rng)
    If Rng(i, 4) >= Clé Then
      n = n + 1: ReDim Preserve Tbl(1 To j, 1 To n)
      C = 0
      For Each k In Total
        C = C + 1: Tbl(C, n) = Rng(i, k)
      Next k
    End If
  Next i
  If n > 0 Then
  Me.Ls_ATA.Column = Tbl
  MySum
  Else
  Me.Ls_ATA.Clear
  End If
End Sub
'*******************
Sub MySum()
Dim Cpt2 As Double, Cpt1 As Double, Cnt As Long
Cnt = 0: Cpt = 0: Cpt1 = 0: Cpt2 = 0
With Ls_ATA
    For r = 0 To .ListCount - 1
        Cnt = Cnt + 1    'عدد النتائج
        Cpt1 = Cpt1 + .List(r, 0) ' مجموع الفواتير
        Cpt2 = Cpt2 + .List(r, 1) ' اجمالي المبلغ
    Next r
End With
LabelCont.Caption = Cnt: SubTotal.Value = Format(Cpt1, "#,##00.00"):: SubTotal2.Value = Cpt2
End Sub

 

 

V2 تجربة.xlsm

تم تعديل مارس 20, 2024 بواسطه محمد هشام.

[sof17]

وهو المطلوب .........شكرا جزيلا يارك الله فيك 

[sof17]

لو كان البحث حصري  من العدد ..إلى عدد  ماهو سطر الذي اغيره في الكود ( عدد الفواتير) مثال : الأكبر او تساوي 10 واقل اوتساوي 12

[محمد هشام.]

 

10 ساعات مضت, sof17 said:

لو كان البحث حصري  من العدد ..إلى عدد  ماهو سطر الذي اغيره في الكود ( عدد الفواتير) مثال : الأكبر او تساوي 10 واقل اوتساوي 12

التغيير اخي سوف يكون هنا  لكن يجب اولا اظافة الشرط الثاني  ودالك باظافة كومبوبوكس جديدة وليكن  اسمه T2  مثلا

    من
If Rng(i, 4) >= Clé Then
الى  
If rng(i, 4) >= Clé And rng(i, 4) <= Clé2 Then

 

وافراغ  جميع الاكواد السابقة من على اليوزرفورم ونسخ الكود التالي 

Dim F, rng, Col, width, j, Total()    
Private Sub UserForm_Initialize()
Dim WS As Worksheet: Set WS = Sheets("data")
  Set d = CreateObject("scripting.dictionary")
  Set F = WS.Range("A2:E" & WS.[C65000].End(xlUp).Row)
  rng = F.Value
  ' الاعمدة الظاهرة على الليست بوكس
  Col = Array(5, 4, 3, 2, 1)
  width = Array(100, 100, 100, 100, 100)
  ' تنسيق عمود المبلغ
  For i = LBound(rng) To UBound(rng): rng(i, 5) = Format(rng(i, 5), "#,##00.00"): Next i
  Me.Ls_ATA.ColumnCount = UBound(Col) + 1
  Me.Ls_ATA.ColumnWidths = Join(width, ";")
  
    Me.Ls_ATA.List = Application.Index(F, Evaluate("Row(1:" & F.Rows.Count & ")"), Col)
    Total = Col: j = UBound(Total) + 1
  ' عمود الفلترة
  ColTri = 4
  For i = LBound(rng) To UBound(rng)
    d(rng(i, ColTri)) = ""
  Next i
  ValTri = d.keys
  ' ترتيب عدد الفواتير على الليست من الاصغر الى الاكبر
  P rng, 4, LBound(rng), UBound(rng)
      ' ترتيب تصاعدي لارقام الفواتير
  tri ValTri, LBound(ValTri), UBound(ValTri)
  ' جلب اصغر عدد
  Me.T1.List = ValTri: Me.T1 = ValTri(0)
  ' جلب اكبر عدد
  Me.T2.List = ValTri: Me.T2 = ValTri(UBound(ValTri))
  MySum
End Sub
'*****************
 Sub Filtre() 'فلترة البيانات
  Dim Tbl(): n = 0: Clé = Val(Me.T1): Clé2 = Val(Me.T2)
  For i = 1 To UBound(rng)
    If rng(i, 4) >= Clé And rng(i, 4) <= Clé2 Then
      n = n + 1: ReDim Preserve Tbl(1 To j, 1 To n)
      C = 0
      For Each k In Total
        C = C + 1: Tbl(C, n) = rng(i, k)
      Next k
    End If
  Next i
  If n > 0 Then
  Me.Ls_ATA.Column = Tbl
  MySum
  Else
  Me.Ls_ATA.Clear
  End If
End Sub
 '******combobox (T1 AND T2) 'ترتيب تصاعدي*************
Sub tri(a, gauc, droi) 
      ref = a((gauc + droi) \ 2)
  g = gauc: d = droi
  Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call tri(a, g, droi)
  If gauc < d Then Call tri(a, gauc, d)
End Sub
  '***ترتيب عدد الفواتير على الليست من الاصغر الى الاكبر******
Sub P(a, V, gauc, droi)
      ref = a((gauc + droi) \ 2, V)
  g = gauc: d = droi
  Do
    Do While a(g, V) < ref: g = g + 1: Loop
    Do While ref < a(d, V): d = d - 1: Loop
    If g <= d Then
       For k = LBound(a, 2) To UBound(a, 2)
         temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp
       Next k
       g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call P(a, V, g, droi)
  If gauc < d Then Call P(a, V, gauc, d)
End Sub
  '*******************************
Sub MySum()
Dim Cpt2 As Double, Cpt1 As Double, Cnt As Long
Cnt = 0: Cpt = 0: Cpt1 = 0: Cpt2 = 0
With Ls_ATA
    For r = 0 To .ListCount - 1
        Cnt = Cnt + 1    'عدد النتائج
        Cpt1 = Cpt1 + .List(r, 0) ' مجموع الفواتير
        Cpt2 = Cpt2 + .List(r, 1) ' اجمالي المبلغ
    Next r
End With
LabelCont.Caption = Cnt: SubTotal.Value = Format(Cpt1, "#,##00.00"):: SubTotal2.Value = Cpt2
End Sub
  '*******************************
Private Sub T2_click()
 If Val(Me.T2) < Val(Me.T1) Then MsgBox "يجب أن يكون الحد الادنى لعدد الفواتير اكبر اويساوي " & Me.T1.Text, vbExclamation, "انتباه" Else Filtre
End Sub
Private Sub T1_click()
  If Val(Me.T1) > Val(Me.T2) Then MsgBox "يجب أن يكون الحد الاقصى لعدد الفواتير اصغر او يساوي " & Me.T2.Text, vbExclamation, "انتباه" Else Filtre
End Sub

اليك الملف للتجربة 

 

 

V3 تجربة (1).xlsm

[sof17]

بارك الله فيك  يعطي نتائج مضبوطة