تحويل كود msg الى استعلام listbox1,2

mahmoud nasr alhasany · يوليو 9

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

الرجاء مساعدتى فى

تحويل كود msg الى CommandButton1 استعلام listbox1,2

وهذا الكود يرمز عند فتح الملف يأتى بالصلاحيات خاصة بمنتجات قريبة الصلاحية ومنتجات انتهت صلاحيتها

Private Sub CommandButton1_Click()
 Dim c As Range, exp As String, msg As String
    
    With Sheets(1)
        
        For Each c In .Range("C2", .Cells(Rows.Count, 3).End(xlUp))
            If c <> "" Then
                
                If c.Value > Date + 6 And c.Value < (Date + 30) Then
                
                exp = exp & c.Offset(, -2).Value & " - " & c.Offset(, -1).Value & " - " & c.Value & vbLf
         
                ElseIf c.Value < (Date + 6) Then
                 
                msg = msg & c.Offset(, -2).Value & " - " & c.Offset(, -1).Value & " - " & c.Value & vbLf
                
                End If
            End If
        Next
    End With
    
    MsgBox exp, vbInformation, "العناصر التي تنتهي صلاحيتها قريبًا"
    
    If msg <> "" Then
        MsgBox "يرجى الإزالة المنتجات من مواقع الأرفف وإزالة البيانات من الملف." & vbNewLine & msg, vbExclamation, "العناصر منتهية الصلاحية"
    End If

End Sub

message for expiring items1.xlsm

تم تعديل يوليو 9 بواسطه mahmoud nasr alhasany

**محمد هشام.** · يوليو 10

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

تفضل اخي @mahmoud nasr alhasany

Private Sub CommandButton1_Click()
Dim x() As Variant
Set f = Sheets(1)
x = Array("ListBox1", "ListBox2")
Set d = CreateObject("Scripting.Dictionary")
Set arr = f.Range("A2:C" & f.[A65000].End(xlUp).Row): a = arr.Value
Dim tmp(): ReDim tmp(1 To UBound(a))
   For i = LBound(a) To UBound(a)
    c = a(i, 3): Results = Array(a(i, 1), a(i, 2), a(i, 3))
If c > Date + 6 And c < (Date + 30) Then
     n = n + 1: tmp(n) = i
   ReDim Preserve tmp(1 To n + 1)
   Me.ListBox1.List = Application.Index(a, Application.Transpose(tmp), _
          Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")")))
     Me.ListBox1.RemoveItem n
       ElseIf c > 0 And c < (Date + 6) Then d(i) = Results
     End If
  Next
  n = d.Count
  If n > 0 Then
    Dim Cnt: Cnt = Application.Transpose(d.items)
    ReDim Preserve Cnt(1 To 3, 1 To n + 1)
    Me.ListBox2.List = Application.Transpose(Cnt)
    Me.ListBox2.RemoveItem n
  End If
For i = 0 To UBound(x): Me.Controls(x(i)).ColumnCount = 3: Next i
End Sub

message for expiring items1 V2.xlsm

تم تعديل يوليو 10 بواسطه محمد هشام.

mahmoud nasr alhasany · يوليو 10

مشكور اخى محمد هشام كود رائع

هل اكملت الاستعلام لو تم تحديده عن طريق OptionButton1,2,3,4

مع العلم ان كل OptionButton

تم تحديد الاستعلام البيانات التى يكون صلاحيتها بداية من اليوم حتى الفترة الزمنية المحدده لها عند الانتهاء وذلك عند اختيار

All and 3Month and 6Month 12Month

عن طريق (صلاحية معينة ) CommandButton3

message for expiring items1 V3.xlsm

mahmoud nasr alhasany · يوليو 10

لقد تم ايجاد الحل

انظر الكود رجاء ا/ محمد هشام لقد اضفت عليها تحديد كل صيغ OptionButton

ام يوجد افضل من هذا كود مختصر اقصد

نريد ان نتعلم من روائعك ا/ محمد هشام

ملحوظة

يوجد بيانات لاتدرج فى الليست بوكس 1 او 2

26723

F16E

10/07/2024

0 days

validity expires yet 0 year, 0 month And 0 days

هى بأختصار البيانات التى تكون متوافه فى هذا اليوم تكون 0 يوم اكسبير نهاية اليوم

رجاء كيف ادرجها فى الليست بوكس 2

مع العلم انها إذا كان يتوافق اليوم نهاية الاكسبير يجب أن تدرج فى الليست بوكس ٢

Private Sub CommandButton3_Click()
ListBox1.Clear
Dim x() As Variant
Set f = Sheets(1)
x = Array("ListBox1", "ListBox2")
Set d = CreateObject("Scripting.Dictionary")
Set arr = f.Range("A2:e" & f.[A65000].End(xlUp).Row): a = arr.Value
Dim tmp(): ReDim tmp(1 To UBound(a))
   For i = LBound(a) To UBound(a)
    c = a(i, 3): Results = Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5))
    
   If OptionButton1 = True Then
If c > Date And c < (Date + 720) Then
     n = n + 1: tmp(n) = i
   ReDim Preserve tmp(1 To n + 1)
   Me.ListBox1.List = Application.Index(a, Application.Transpose(tmp), _
          Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")")))
     Me.ListBox1.RemoveItem n
       ElseIf c > 0 And c < (Date) Then d(i) = Results
     End If
  
ElseIf OptionButton2 = True Then
If c > Date And c < (Date + 90) Then
     n = n + 1: tmp(n) = i
   ReDim Preserve tmp(1 To n + 1)
   Me.ListBox1.List = Application.Index(a, Application.Transpose(tmp), _
          Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")")))
     Me.ListBox1.RemoveItem n
       ElseIf c > 0 And c < (Date) Then d(i) = Results
     End If
  
ElseIf OptionButton3 = True Then
If c > Date And c < (Date + 180) Then
     n = n + 1: tmp(n) = i
   ReDim Preserve tmp(1 To n + 1)
   Me.ListBox1.List = Application.Index(a, Application.Transpose(tmp), _
          Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")")))
     Me.ListBox1.RemoveItem n
       ElseIf c > 0 And c < (Date) Then d(i) = Results
     End If
  
ElseIf OptionButton4 = True Then
If c > Date And c < (Date + 360) Then
     n = n + 1: tmp(n) = i
   ReDim Preserve tmp(1 To n + 1)
   Me.ListBox1.List = Application.Index(a, Application.Transpose(tmp), _
          Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")")))
     Me.ListBox1.RemoveItem n
       ElseIf c > 0 And c < (Date) Then d(i) = Results
     End If
     End If
     
  Next
  
  n = d.Count
  If n > 0 Then
    Dim Cnt: Cnt = Application.Transpose(d.items)
    ReDim Preserve Cnt(1 To 5, 1 To n + 1)
    Me.ListBox2.List = Application.Transpose(Cnt)
    Me.ListBox2.RemoveItem n
  End If
For i = 0 To UBound(x): Me.Controls(x(i)).ColumnCount = 5: Next i
End Sub

message for expiring items1 V3.xlsm

تم تعديل يوليو 10 بواسطه mahmoud nasr alhasany

**محمد هشام.** · يوليو 11

7 ساعات مضت, mahmoud nasr alhasany said:

ام يوجد افضل من هذا كود مختصر اقصد

جرب هدا

Private Sub CommandButton3_Click()
Dim x() As Variant
Set f = Sheets(1): x = Array("ListBox1", "ListBox2")
For i = 0 To UBound(x): Me.Controls(x(i)).Clear:: Next i
Set d = CreateObject("Scripting.Dictionary")
Set arr = f.Range("A2:E" & f.[A65000].End(xlUp).Row): a = arr.Value
Dim tmp(): ReDim tmp(1 To UBound(a))
For i = LBound(a) To UBound(a)
c = a(i, 3): Results = Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5))
If OptionButton1 = True And c > Date And c <= (Date + 720) Or _
      OptionButton2 = True And c > Date And c <= (Date + 90) Or _
        OptionButton3 = True And c > Date And c <= (Date + 180) Or _
          OptionButton4 = True And c > Date And c <= (Date + 360) Then
     n = n + 1: tmp(n) = i
   ReDim Preserve tmp(1 To n + 1)
   Me.ListBox1.List = Application.Index(a, Application.Transpose(tmp), _
          Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")")))
     Me.ListBox1.RemoveItem n
       ElseIf c > 0 And c <= (Date) Then d(i) = Results
     End If
  Next
  n = d.Count
  If n > 0 And Me.OptionButton1 = True Or Me.OptionButton2 = True Or _
               Me.OptionButton3 = True Or Me.OptionButton4 = True Then
    Dim cnt: cnt = Application.Transpose(d.items)
    ReDim Preserve cnt(1 To 5, 1 To n + 1)
    Me.ListBox2.List = Application.Transpose(cnt)
    Me.ListBox2.RemoveItem n
  End If
For i = 0 To UBound(x)
With Me.Controls(x(i))
 .ColumnCount = 5: .ColumnWidths = "55;50;80;50;50"
    End With
  Next i
End Sub

mahmoud nasr alhasany · يوليو 11

احسنت 1 محمد هشام انه كود حقا رائع

انه يعمل حقا

اريد استفسار

بالنسبة لهذه الاكواد التى تشمل عدد الايام المقسمة الى 3 اشهر او 6 اشهر او 12 شهرا (سنة) او 48 شهرا (سنتان)

OptionButton1 = True And c > Date And c <= (Date + 720)
OptionButton2 = True And c > Date And c <= (Date + 90)
OptionButton3 = True And c > Date And c <= (Date + 180)

OptionButton4 = True And c > Date And c <= (Date + 360)

كمثال (Date + 90)

لو وجدنا ان 90 يوما كمثال شهرمايو يونيو ويوليو =92 يوما وليس 90 وهكذا فى باقى الاشهر اذا كانت المعادلة 720 او 360 او 180 او 90

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

وشكرا لك

mahmoud nasr alhasany · يوليو 11

Private Sub CommandButton3_Click()
ListBox1.Clear
Dim x() As Variant
Set f = Sheets(1): x = Array("ListBox1", "ListBox2")
For i = 0 To UBound(x): Me.Controls(x(i)).Clear:: Next i
Set d = CreateObject("Scripting.Dictionary")
Set arr = f.Range("A2:E" & f.[A65000].End(xlUp).Row): a = arr.Value
Dim tmp(): ReDim tmp(1 To UBound(a))
For i = LBound(a) To UBound(a)
c = a(i, 3): Results = Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5))
If OptionButton1 = True And c > Date And c <= CDate(WorksheetFunction.EDate(Date, 48)) Or _
      OptionButton2 = True And c > Date And c <= CDate(WorksheetFunction.EDate(Date, 3)) Or _
        OptionButton3 = True And c > Date And c <= CDate(WorksheetFunction.EDate(Date, 6)) Or _
          OptionButton4 = True And c > Date And c <= CDate(WorksheetFunction.EDate(Date, 12)) Then
     n = n + 1: tmp(n) = i
   ReDim Preserve tmp(1 To n + 1)
   Me.ListBox1.List = Application.Index(a, Application.Transpose(tmp), _
          Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")")))
     Me.ListBox1.RemoveItem n
       ElseIf c > 0 And c <= (Date) Then d(i) = Results
     End If
  Next
  n = d.Count
  If n > 0 And Me.OptionButton1 = True Or Me.OptionButton2 = True Or _
               Me.OptionButton3 = True Or Me.OptionButton4 = True Then
    Dim cnt: cnt = Application.Transpose(d.items)
    ReDim Preserve cnt(1 To 5, 1 To n + 1)
    Me.ListBox2.List = Application.Transpose(cnt)
    Me.ListBox2.RemoveItem n
  End If
For i = 0 To UBound(x)
With Me.Controls(x(i))
 .ColumnCount = 5: .ColumnWidths = "55;50;80;50;50"
    End With
  Next i
End Sub

لقد وجد الحل هل يكفى ام يوجد كود اخر مختلف

If OptionButton1= True And c > Date And c <= CDate(WorksheetFunction.EDate(Date, 48))Or _
      OptionButton2 = True And c > Date And c <= CDate(WorksheetFunction.EDate(Date, 3)) Or _
      OptionButton3 = True And c > Date And c <= CDate(WorksheetFunction.EDate(Date, 6)) Or _
  OptionButton4 = True And c > Date And c <= CDate(WorksheetFunction.EDate(Date, 12)) Then

بدل هذا الكود

If OptionButton1 = True And c > Date And c <= (Date + 720) Or _
      OptionButton2 = True And c > Date And c <= (Date + 90) Or _
        OptionButton3 = True And c > Date And c <= (Date + 180) Or _
          OptionButton4 = True And c > Date And c <= (Date + 360) Then

message for expiring items1 V4.xlsm

تم تعديل يوليو 11 بواسطه mahmoud nasr alhasany

**محمد هشام.** · يوليو 11

اخي @mahmoud nasr alhasany بما ان الكود يعطي نتائج صحيحة ومرضية بالنسبة لك لا حاجة لتغييره

هناك ملاحظة بسيطة اظن انك لم تقرأ الكود جيدا يمكنك الاستغناء عن كود التهيئة Private Sub UserForm_Initialize()

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

Private Sub CommandButton3_Click()
Dim x() As Variant
Set f = Sheets(1): x = Array("ListBox1", "ListBox2")
'تفريغ عناصر الليست بوكس
For i = 0 To UBound(x): Me.Controls(x(i)).Clear:: Next i
'Code ......
...................
   ' تحديد عدد وعرض الاعمدة على الليست بوكس
For i = 0 To UBound(x)
With Me.Controls(x(i))
 .ColumnCount = 5: .ColumnWidths = "50;60;65;50;95"
    End With
  Next i
End Sub
'===================================================

Private Sub CommandButton1_Click()
' اضف هدا في اخر الكود ليتم الغاء تحديد العناصر بعد تنفيده 
'Code.......
......
For s = 1 To 4
    Me("OptionButton" & s).Value = False
Next
End Sub

message for expiring items1 V5.xlsm

mody200 · يوليو 11

عمل رائع

تم تعديل يوليو 11 بواسطه mody200

تسجيل الدخول

تحويل كود msg الى استعلام listbox1,2

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

mahmoud nasr alhasany

محمد هشام.

mahmoud nasr alhasany

mahmoud nasr alhasany

محمد هشام.

mahmoud nasr alhasany

mahmoud nasr alhasany

محمد هشام.

mody200

Join the conversation

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

تصفح الموقع

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

Support

Important Information