mahmoud nasr alhasany

بخصوص التعديل لم يتم حل المشكلة Private Sub CommandButton2_Click() ' ' ... your existing code ... ' ' ' Data validation ' If Not IsNumeric(TextBox1.Value) Then ' MsgBox "Quantity must be a number." ' Exit Sub ' End If ' ' If ComboBox1.ListIndex = -1 Then ' MsgBox "Please select a store to transfer from." ' Exit Sub ' End If ' ... rest of your code ... Dim wsSales As Worksheet, wsStock As Worksheet Dim lastRowSales As Long, lastRowStock As Long Dim i As Long, j As Long Dim invoiceNo As Long, fromStore As String, toStore As String, itemCode As String, quantity As Long, newQuantity As Long invoiceNo = Val(TextBox2.Value) fromStore = ComboBox1.Value toStore = ComboBox2.Value ' ComboBox1 رصيد المخزون الاول fromStore1 = stocktr.Value ' ComboBox2 رصيد المخزون الثانى toStore2 = stocktrr.Value Set wsSales = Worksheets("Transferts") Set wsStock = Worksheets("Inventaire") ' Find the invoice in the Sales sheet lastRowSales = wsSales.Cells(wsSales.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRowSales If wsSales.Cells(i, "A").Value = invoiceNo Then ' Get the new quantity from the user (مثال: عن طريق TextBox) newQuantity = Val(TextBox1.Value) ' Calculate the quantity difference quantity = wsSales.Cells(i, "H").Value Dim quantityDiff As Long quantityDiff = newQuantity + quantity ' Update the quantity in the Sales sheet wsSales.Cells(i, "H").Value = newQuantity wsSales.Cells(i, "k").Value = Now() ' تاريخ التعديل wsSales.Cells(i, "l").Value = Environ("Username") ' اسم المستخدم End If Next i ' Find the invoice in the Stock sheet lastRowStock = wsStock.Cells(wsStock.Rows.Count, "A").End(xlUp).Row For j = 2 To lastRowStock If wsStock.Cells(j, "A").Value = fromStore Then ' Get the new quantity from the user (مثال: عن طريق TextBox) newQuantity = Val(TextBox1.Value) ' Calculate the quantity difference quantity = wsStock.Cells(j, "D").Value quantityDiff = newQuantity - quantity ' Update the quantity in the Sales sheet wsStock.Cells(j, "D").Value = newQuantity + fromStore1 ' Update quantities in the inventory ' ... (نفس الكود السابق لإرجاع الكميات) ' Find the invoice in the Stock sheet ' lastRowStock = wsStock.Cells(wsStock.Rows.Count, "A").End(xlUp).Row ' For j = 2 To lastRowStock ElseIf wsStock.Cells(j, "A").Value = toStore Then ' Get the new quantity from the user (مثال: عن طريق TextBox) newQuantity = Val(TextBox1.Value) ' Calculate the quantity difference quantity = wsStock.Cells(j, "D").Value quantityDiff = newQuantity + quantity ' Update the quantity in the Sales sheet wsStock.Cells(j, "D").Value = newQuantity + toStore2 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' wsStock.Cells(j, "D").Value = newQuantity - TextBox1 + toStore2 - TextBox1 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' wsStock.Cells(j, "J").Value = Now() ' تاريخ التعديل wsStock.Cells(j, "K").Value = Environ("Username") ' اسم المستخدم End If Next j MsgBox "تم تعديل الفاتورة وإرجاع الكميات بنجاح" End Sub امين مخزن3.xlsm

وهذا الكود خاص بتعديل الفاتورة وارجاع الكمية الصحية لمخزون المخزن ان كمية المخزون المستردة يجب ان تكون ناقصة فى If wsStock.Cells(j, "A").Value =TOStore Then Private Sub CommandButton2_Click() Dim wsSales As Worksheet, wsStock As Worksheet Dim lastRowSales As Long, lastRowStock As Long Dim i As Long, j As Long Dim invoiceNo As Long, fromStore As String, toStore As String, itemCode As String, quantity As Long, newQuantity As Long invoiceNo = Val(TextBox2.Value) fromStore = ComboBox1.Value toStore = ComboBox2.Value ' ComboBox1 رصيد المخزون الاول fromStore1 = stocktr.Value ' ComboBox2 رصيد المخزون الثانى toStore2 = stocktrr.Value Set wsSales = Worksheets("Transferts") Set wsStock = Worksheets("Inventaire") ' Find the invoice in the Sales sheet lastRowSales = wsSales.Cells(wsSales.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRowSales If wsSales.Cells(i, "A").Value = invoiceNo Then ' Get the new quantity from the user (مثال: عن طريق TextBox) newQuantity = Val(TextBox1.Value) ' Calculate the quantity difference quantity = wsSales.Cells(i, "H").Value Dim quantityDiff As Long quantityDiff = newQuantity + quantity ' Update the quantity in the Sales sheet wsSales.Cells(i, "H").Value = newQuantity End If Next i ' Find the invoice in the Stock sheet lastRowStock = wsStock.Cells(wsStock.Rows.Count, "A").End(xlUp).Row For j = 2 To lastRowStock If wsStock.Cells(j, "A").Value = toStore Then ' Get the new quantity from the user (مثال: عن طريق TextBox) newQuantity = Val(TextBox1.Value) ' Calculate the quantity difference quantity = wsStock.Cells(j, "D").Value quantityDiff = newQuantity - quantity ' Update the quantity in the Sales sheet wsStock.Cells(j, "D").Value = newQuantity + toStore2 ' Update quantities in the inventory ' ... (نفس الكود السابق لإرجاع الكميات) ' Find the invoice in the Stock sheet ElseIf wsStock.Cells(j, "A").Value = fromStore Then ' Get the new quantity from the user (مثال: عن طريق TextBox) newQuantity = Val(TextBox1.Value) ' Calculate the quantity difference quantity = wsStock.Cells(j, "D").Value quantityDiff = newQuantity + quantity ' Update the quantity in the Sales sheet wsStock.Cells(j, "D").Value = newQuantity + fromStore1 wsStock.Cells(lastRowStock + 1, "J").Value = Now() ' تاريخ التعديل wsStock.Cells(lastRowStock + 1, "K").Value = Environ("Username") ' اسم المستخدم End If Next j MsgBox "تم تعديل الفاتورة وإرجاع الكميات بنجاح" End Sub الرجاء مساعدتى انى عالق

السلام عليكم ورحمة الله وبركاتة رجاء مساعدتى فى هذا الموضوع انه حذف فاتورة ,وايضا التعديل على الفاتورة سنبتدى على طريقة الحذف اولا * حذف فاتورة: تحديد رقم فاتورة في TextBox2 وحذفها من ورقة المبيعات. * إرجاع الكميات: إرجاع الكميات الخاصة بالأصناف الموجودة في الفاتورة إلى ورقة المخزون المقابلة. * تعريف المخزن: تحديد ورقة المخزون الصحيحة بناءً على مخزن الفاتورة. 1. تصميم نموذج المستخدم (UserForm): * TextBox2: لإدخال رقم الفاتورة. * Combobox1: لعرض تفاصيل اسم المخزن المحول منه الفاتورة * Combobox2: لعرض تفاصيل اسم المخزن المحول منه الفاتورة * ListBox1: لعرض تفاصيل الأصناف في الفاتورة المحددة * الأعمدة التالية : تفاصيل الأصناف فى listbox 1 (كود الصنف، اسم الصنف ،الكمية). * زر حذف: لتنفيذ عملية الحذف وإرجاع الكميات. 2. تفاصيل بيانات ورقة المبيعات: * العمود A: رقم الفاتورة. * العمود B: تاريخ الفاتورة. * العمود C : اسم المخزن. * العمود d: اسم المخزن.المحول منه * العمود E: اسم المخزن.المحول اليه * العمود F: كود الصنف * العمود G: اسم الصنف * العمود H: الكميه * الأعمدة التالية: تفاصيل الأصناف فى ورقة المخزون (اسم للمخزن ،كود الصنف، اسم الصنف،الرصيد المخزون). 3. تفاصيل بيانات ورقة المخزون: * العمود A: اسم المخزن. * العمود B: كود الصنف * العمود C : اسم الصنف * العمود d: الرصيد. 4. كود VBA: المطلوب عند الحذف الكمية من مخزن محدد من ورقة المبيعات ارجاع الكمية الى المخزون من المخزن المحول منه وخصم الكمية من المحول الية مالخطاء فى الكود المدرج Private Sub CommandButton3_Click() If ListBox1.ListIndex = -1 Then: Exit Sub If ListBox1.ListIndex = -1 Then '''''حدف البيانات من الليست بوكس''''' MsgBox "!المرجوا تحديد الصف المراد حدفه !", vbCritical, "" Exit Sub End If If ListBox1.ListIndex >= 0 Then cevap = MsgBox("?هل أنت متأكد أنك تريد حذف العنصر المحدد", vbYesNo) If cevap = vbYes Then ListBox1.RemoveItem ListBox1.ListIndex REMOVE End If End If On Error Resume Next Dim wsSales As Worksheet, wsInventory As Worksheet Dim lastRowSales As Long, lastRowInventory As Long Dim deleteRow As Long Dim itemRow As Long Dim invoiceNumber As Long, itemCode As String, warehouseName As String, quantity As Integer, warehouseFrom As String, warehouseTo As String ' تحديد ورقة المبيعات والمخزون Set wsSales = ThisWorkbook.Sheets("Transferts") Set wsInventory = ThisWorkbook.Sheets("Inventaire") ' الحصول على رقم الفاتورة من TextBox2 invoiceNumber = Val(TextBox2.Value) ' البحث عن الصف الذي يحتوي على الفاتورة المحددة lastRowSales = wsSales.Cells(wsSales.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRowSales If wsSales.Cells(i, "A").Value = invoiceNumber Then deleteRow = i Exit For End If Next i ' إذا تم العثور على الفاتورة، قم بحذفها وإرجاع الكميات If deleteRow > 0 Then ' الحصول على اسم المخزن من الصف الذي سيتم حذفه ' warehouseName = wsSales.Cells(deleteRow, "C").Value warehouseFrom = wsSales.Cells(deleteRow, "D").Value warehouseTo = wsSales.Cells(deleteRow, "E").Value ' ملء ListBox1 ببيانات الأصناف ListBox1.Clear For itemRow = 6 To wsSales.Cells(deleteRow - 1, wsSales.Columns.Count).End(xlToLeft).Column Step 3 itemCode = wsSales.Cells(deleteRow - 1, itemRow).Value itemName = wsSales.Cells(deleteRow - 1, itemRow + 1).Value quantity = wsSales.Cells(deleteRow - 1, itemRow + 2).Value ListBox1.AddItem itemCode & " - " & itemName & " - " & quantity Next itemRow ' حذف الصف من ورقة المبيعات wsSales.Rows(deleteRow).EntireRow.Delete ' البحث عن الأصناف في الفاتورة وإرجاع الكميات إلى المخزن المصدر For Each Item In ListBox1.List 'ListItems ItemData = Split(Item.Value, " - ") itemCode = ItemData(0) quantity = CInt(ItemData(2)) ' البحث عن الصنف في ورقة المخزون وإضافة الكمية إلى المخزن المصدر lastRowInventory = wsInventory.Cells(wsInventory.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRowInventory If wsInventory.Cells(i, "B").Value = itemCode And wsInventory.Cells(i, "A").Value = warehouseFrom Then wsInventory.Cells(i, "D").Value = wsInventory.Cells(i, "D").Value + quantity ' التأكد من عدم وجود كميات سالبة If wsInventory.Cells(i, "D").Value < 0 Then MsgBox "الكمية في المخزن أصبحت سالبة للصنف " & itemCode Exit Sub End If Exit For End If Next i Next itemRow Else MsgBox "لم يتم العثور على الفاتورة" End If Next i Next Item Else MsgBox "لم يتم العثور على الفاتورة" End If End Sub مالخطاء فى تنفيذ الكود فى الفورم Copy of Copy of امين مخزن.xlsm

السلام عليكم ورحمة الله وبركاتة شرح بالتفصيل لعملية البحث عن رقم فاتورة وعرض البيانات المرتبطة بها في VBA Excel فهم المطلوب نريد أن نقوم بإنشاء نموذج في Excel VBA حيث: * TextBox2: لإدخال رقم الفاتورة للبحث عنه. * TextBox5: لعرض تاريخ الفاتورة بعد البحث. * ComboBox1: لعرض اسم المخزن المحول منه بعد البحث. * ComboBox2: لعرض اسم المخزن المحول الية بعد البحث. * ListBox1: لعرض تفاصيل المنتج (كود، اسم، كمية) لكل منتج في الفاتورة. خطوات التنفيذ 1. تصميم UserForm: * قم بإنشاء UserForm جديد في Excel VBA. * أضف عناصر التحكم التالية: * TextBox2: لإدخال رقم الفاتورة. * TextBox5: لعرض تاريخ الفاتورة. * ComboBox1: لعرض اسم المخزن المحول منه * ComboBox2: لعرض اسم المخزن المحول الية * ListBox1: لعرض تفاصيل المنتجات. * CommandButton1: لتنفيذ عملية البحث. 2. إعداد البيانات في ورقة العمل: * افترض أن لدينا ورقة عمل باسم "Transferts" تحتوي على الأعمدة التالية: * رقم الفاتورة * تاريخ الفاتورة * اسم المخزن المحول منه * اسم المخزن المحول الية * كود المنتج * اسم المنتج * الكمية تم عمل المطلوب ولاكن عند الاستعلام عن الفاتورة لايتم عرض البيانات فى ComboBox1: لعرض اسم المخزن المحول منه ComboBox2: لعرض اسم المخزن المحول الية ويكتفى بعرض البيانات فى listbox1 فقط Private Sub Search_Click() Dim ws As Worksheet Dim LastRow As Long Dim i As Long Dim ii As Long Dim searchValue As String Set ws = ThisWorkbook.Sheets("Transferts") ' اسم ورقة العمل LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row searchValue = TextBox2.Value ' مسح قوائم قبل عملية البحث ListBox1.Clear ComboBox1.Clear ComboBox2.Clear ComboBox3.Clear ComboBox4.Clear TextBox1 = "" For i = 2 To LastRow If ws.Cells(i, 1).Value = searchValue Then ' البحث عن رقم الفاتورة TextBox5.Value = ws.Cells(i, 2).Value ' عرض التاريخ If ComboBox1.ListCount = 0 Then ComboBox1.AddItem ws.Cells(i, 4).Value ' عرض اسم المخزن المحول منة ComboBox2.AddItem ws.Cells(i, 5).Value ' عرض اسم المخزن المحول الية End If 'ListBox1.AddItem ws.Cells(i, 6).Value & " - " & ws.Cells(i, 7).Value & " - " & ws.Cells(i, 8).Value Me.ListBox1.AddItem ws.Cells(i, 6) ' عرض كود الصنف Me.ListBox1.List(ListBox1.ListCount - 1, 1) = ws.Cells(i, 7) ' عرض اسم الصنف Me.ListBox1.List(ListBox1.ListCount - 1, 2) = ws.Cells(i, 8) ' عرض الكمية End If Next i Me.ListBox1.ColumnCount = 4 Me.ListBox1.ColumnWidths = "130;130;55" End Sub 'المشكلة فى الكود هذا 'If ComboBox1.ListCount = 0 Then ' ComboBox1.AddItem ws.Cells(i, 4).Value ' عرض اسم المخزن المحول منة ' ComboBox2.AddItem ws.Cells(i, 5).Value ' عرض اسم المخزن المحول الية ' End If Copy of امين مخزن.xlsm

Private Sub CommandButton1_Click() Dim i As Integer Dim item As String Dim qty1 As Integer, qty2 As Integer Dim stock1 As Integer, stock2 As Integer Dim multiplier As Integer ' تحقق من التحديد في ListBox1 If ListBox1.ListIndex = -1 Then MsgBox "Please select an item from ListBox1.", vbExclamation Exit Sub End If ' الحصول على القيم من ListBox1 وTextBox1 item = ListBox1.Value qty1 = Val(ListBox1.Column(1)) stock1 = Val(ListBox1.Column(2)) multiplier = Val(TextBox1.Value) 'ابحث عن العنصر في ListBox2 For i = 0 To ListBox2.ListCount - 1 If ListBox2.List(i) = item Then qty2 = Val(ListBox2.Column(1)) stock2 = Val(ListBox2.Column(2)) Exit For End If Next i ' تحقق من العثور على العنصر في ListBox2 If i = ListBox2.ListCount Then MsgBox "Item not found in ListBox2.", vbExclamation Exit Sub End If ' حساب الكميات والمخزونات الجديدة qty2 = qty2 - (qty1 * multiplier) stock2 = stock2 - (stock1 * multiplier) ' ضمان القيم غير السلبية If qty2 < 0 Or stock2 < 0 Then MsgBox "Insufficient quantity or stock in ListBox2.", vbExclamation Exit Sub End If ' Update ListBox2 ListBox2.List(i, 1) = qty2 ListBox2.List(i, 2) = stock2 End Sub مالخطاء فى هذا الكود الشرح داخل ملف العمل انها عملية تحويل كمية بين المخازن من LISTBOX1 TO LISTBOX2 تحويل الكمية بين المخازن.xlsm

وهذا حل من الحلول وتم تبسيط الكود لقد ادركت عندما تكون الكمية صفر اعلى الحدث والكمية الاخرى 12 تكون اسفل فلايقوم بحذف مع العلم ان كود المخزن وكود المنتج مكرر وعندما اضفت كود اخر وهى SortData ليجعل القيمة الصفر اسفل ليقوم بتنشيط الكود ويبدأعملية الحذف المكرره وعندما لايوجد منتج ولا مخزن مكرر فى حالة ان كانت الكمية صفر فلايقوم بحزف الخلية كاملا Sub RemoveDuplicatesWithMultipleConditions1() Dim lastRow As Long Dim i As Long, j As Long Set ws = Sheet3 SortData ' Find the last row with data lastRow = ws.Cells(Rows.count, "A").End(xlUp).row ' Loop through the data For i = lastRow To 2 Step -1 For j = i - 1 To 1 Step -1 ' Check for duplicate conditions If Cells(i, "A").Value = Cells(j, "A").Value And _ Cells(i, "b").Value = Cells(j, "b").Value And _ Cells(i, "c").Value = 0 And _ Cells(i, "d").Value = Cells(j, "d").Value Then Rows(i).Delete Exit For End If Next j Next i End Sub Sub SortData() Columns.Sort key1:=Columns("a"), Order1:=xlAscending, Key2:=Columns("c"), Order2:=xlDescending, Header:=xlYes End Sub

احسنت استاذنا الفاضل / محمد طاهر عرفه وايضا اشكر السيد / AbuuAhmed على مجهودة الرائع فى مساعدتة لحل مشكلتى فى اكثر من طرق حل وكلاهما رائعين

الف شكر AbuuAhmed

انظر لقد رأيت المشكلة موضحة فى الشرح داخل ملف الاكسيل Copy of Stock123.xlsm

Stock123.xlsm هذا هو الملف مالخطاء فى الكود

صباح الخير لدي خمسة أعمدة كود المنتج إسم المنتج كمية اسم المخزن صلاحية المنتج يوجد تكرار في رمز المنتج واسم المخزن بسبب اختلاف تاريخ انتهاء المنتج مثال 100: المنتج:12: مخزن : 01/05/2024 100: المنتج:26: مخزن : 01/01/2024 عندما تكون الكمية 26 (صفر)، فإنها تقوم بالحذف نهائى عندما تتوافر الشروط كود (المنتج واسم المخزن)+ الصلاحية أما بالنسبة للمنتج لهذا المخزن عندما تكون الكمية 12 (صفر) لايقوم يحذفه لأنه غير مكرر مثل 100: المنتج: 12: مخزن: 01/05/2024 الى 100: المنتج: 0: مخزن: 01/05/2024 يوجد صورة مدرجة للتوضيح قبل المطلوب تنفيذة وبعد تنشيط الكود واكون شاكر جداااا للمساعدة فقد يأست من تنفيذ ونجاح ورقة العمل يوجد مشكلة فى الكود Sub KeepZeroDuplicates() Dim ws As Worksheet Dim lastRow As Long Dim checkRange As Range Dim checkCols As Variant Dim data As Variant Dim i As Long, j As Long, k As Long ' Set worksheet and last row Set ws = ActiveSheet ' Replace with your sheet name if needed lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' Adjust column if needed ' Specify columns to check for duplicates and zero values checkCols = Array(1, 2, 3, 4, 5) ' Replace with column numbers ' Store data in an array for efficient processing data = ws.Range("A1:E" & lastRow).Value ' Adjust range as needed ' Loop through data array For i = 2 To UBound(data, 1) ' Start from second row For j = 2 To i - 1 ' Check for duplicate in specified columns If IsDuplicate(data, i, j, checkCols) Then ' Check if any value in check columns is zero For k = LBound(checkCols) To UBound(checkCols) If data(i, checkCols(k)) = 0 Then Exit For Next k If k <= UBound(checkCols) Then ' Duplicate found with zero value, keep it Exit For Else ' Duplicate without zero value, delete row ws.Rows(i).Delete i = i - 1 Exit For End If End If Next j Next i End Sub Function IsDuplicate(data As Variant, row1 As Long, row2 As Long, checkCols As Variant) As Boolean Dim k As Long For k = LBound(checkCols) To UBound(checkCols) If data(row1, checkCols(k)) <> data(row2, checkCols(k)) Then IsDuplicate = False Exit Function End If Next k IsDuplicate = True End Function

بسم لله ماشاء الله احسنت ا/ محمد هشام

احسنت جزاك الله خيرا

احسنت ا/ محمد هشام انت رائع حقا حفظك الله

Private Sub b_recup_Click() On Error Resume Next Dim Y As Date Dim X As Integer Set fS = Sheets("تصدير بيانات اكسيل") fS.Rows("3:3999").Select Selection.Delete Shift:=xlUp fS.[a2:m3999].ClearContents r1 = Text_count.Value Sheet3.Range("a2:m3999").ClearContents hrd1 = Array("رصيد اول مدة") fS.[c2].Resize(1, 1) = hrd1 fS.Range("f2") = ("بيان رصيد اول مدة بتاريخ هذا اليوم") fS.Range("g2") = Text_count fS.Range("i2") = Text_count fS.Range("b2") = Format(DateAdd("d", -1, CDate(Me.DateMini.Value)), "dd/mm/yyyy") a = Me.ListBox1.List fS.[A3].Resize(UBound(a) + 1, UBound(a, 2) + 1) = a c = 0 For c = 1 To Irow fS.Cells(1, c) = Range(NomTableau).Offset(-1).Item(1, c) Next Ligs = fS.Range("A" & Rows.Count).End(xlUp)(2).Row fS.Range("f" & Ligs) = ("اجمالى") fS.Range("g" & Ligs) = TextBox3 fS.Range("h" & Ligs) = TextBox2 fS.Range("i" & Ligs) = TextBox1 ' f2.Cells.EntireColumn.AutoFit fS.Columns(13).ClearContents MsgBox "تم تصدير البيانات بنجاح" Unload Me Set Rng = fS.Range("A1").CurrentRegion fS.PageSetup.PrintArea = Rng.Address fS.PrintPreview fS.Zoom End Sub تم عمل المطلوب جرب هذا الكود

جميل حقا

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

احسنت 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 هل يوجد صيغة بدل الارقام لتكون الاستعلام صحيحا وشكرا لك

لقد تم ايجاد الحل انظر الكود رجاء ا/ محمد هشام لقد اضفت عليها تحديد كل صيغ 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

مشكور اخى محمد هشام كود رائع هل اكملت الاستعلام لو تم تحديده عن طريق OptionButton1,2,3,4 مع العلم ان كل OptionButton تم تحديد الاستعلام البيانات التى يكون صلاحيتها بداية من اليوم حتى الفترة الزمنية المحدده لها عند الانتهاء وذلك عند اختيار All and 3Month and 6Month 12Month عن طريق (صلاحية معينة ) CommandButton3 message for expiring items1 V3.xlsm

السلام عليكم ورحمة الله وبركاتة الرجاء مساعدتى فى تحويل كود 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

احسنت ا/ محمد هشام انت رائع

السلام عليكم ورحمة الله وبركاتة الرجاء المساعدة فى عمل كود طباعة بواسطة PDF And Word Private Sub WordView_Click() End Sub and Private Sub PDFConvertor_Click() End Sub Private Sub WordView_Click() End Sub and Private Sub PDFConvertor_Click() End Sub كرت الصنف 2024.xlsm

لقد ارفقته بالفعل وتم تعديل الملف أعلى المنشور وارفقت الصوره بالتنسيق المطلوب وشكرا لك احسنت هذا هو المطلوب هل تقوم بمساعدتى فى اكمال هذا الموضوع وجعله يقوم بتصدير البيانات إلى وورد أو بى دى اف يوجد اتنين button واحده خاصه بالورد والثانيه بى دى اف