mahmoud nasr alhasany

صباح الخير لدي خمسة أعمدة كود المنتج إسم المنتج كمية اسم المخزن صلاحية المنتج يوجد تكرار في رمز المنتج واسم المخزن بسبب اختلاف تاريخ انتهاء المنتج مثال 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 واحده خاصه بالورد والثانيه بى دى اف

مثل هذه

عند كل امر طباعة بعد الاستعلام يقوم بحذف التنسيقات ولاكن اريد تنسيقات ليست مسطرة فقط ولاكن بشكل متقدم ورائع

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

Private Sub Image1_Click() Sheet5.Select Cells.Select Sheet5.Range("a1:h3999").ClearContents Selection.Clear Range("A1").Select Application.ScreenUpdating = False Sheet5.Cells(1, 1) = " من تاريخ " Sheet5.Cells(1, 2) = Me.TextBox1 Sheet5.Cells(2, 1) = " الى تاريخ " Sheet5.Cells(2, 2) = Me.TextBox2 Sheet5.Cells(1, 4) = "اسم المخزن" Sheet5.Cells(1, 5) = ComboBox1 Sheet5.Cells(2, 4) = "اسم الصنف" Sheet5.Cells(2, 5) = ComboBox2 Sheet5.Cells(1, 6) = " رصيداول مدة " Sheet5.Cells(2, 6) = TextBox3 Sheet5.Cells(3, 1) = "رقم المستند" Sheet5.Cells(3, 2) = "التاريخ" Sheet5.Cells(3, 3) = "نوع الحركة" Sheet5.Cells(3, 4) = "اسم المخزن" Sheet5.Cells(3, 5) = "اسم الصنف" Sheet5.Cells(3, 6) = "شراء" Sheet5.Cells(3, 7) = "بيع" Sheet5.Cells(3, 8) = "الرصيد" a = Sheet5.Range("d500").End(xlUp).Row For I = 0 To Me.ListBox1.ListCount - 1 For x = 0 To 7 Sheet5.Cells(I + 4, x + 1) = Me.ListBox1.List(I, x) Next x Next I Unload Me Sheet5.PrintPreview Sheet5.Select End Sub مساعدة فى تنسيق ورقة العمل sheet5 بحيث تكون منسقة فى الطباعة فعند الاستعلام بأسم المخزن واسم الصنف بين تاريخين مع استخدام امر بحث من option تكون ورقة الطباعة بشكل مسطر ومنسق كرت الصنف 2024.xlsm

هو برنامج محاسبى مجانى مفتوح المصدر عند كتابة اليوزرنيم يقوم بالاغلاق مع العلم ان اسم الادمن admin والباسورد 123 الرجاء مساعدتى فى ايجاد المشكله التى يتعرض لها البرنامج EASY_SALE.zip

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

احسنت ا/ حسونة حسين بارك الله فيك

ممتاذ احسنت استاذ / محمد هشام

احسنت ا/ محمد هشام

لقد صممت كارت الصنف للمخازن يوضح المخزون والكميات الواردة والكميات الصادرة والكميات المتاحة مع رصيد افتتاحى واستعلام كلى او مخزن معين بين تاريخين الرجاء استكمال الفورم بخصوص الطباعة بأكثر من صيغة سواء وورد او اكسيل او بى دى اف وبشكل منسق وايضا الرجاء ان يكون الخيار الطباعة من خلال الملف او ملف اكسيل خارجى وارجو من الاستاذ حسونة حسين كرت الصنف 2024.xlsmو الاستاذ محمد هشام ان يلقوا نظرة سريعة بخصوص الفورم وطريقة عملة هل مجدية ام يوجد اصلاحات عليها وشكر ا لكم كرت الصنف 2024.xlsm

فاتورة خبوريه من اعمال السيد/ ضاحى غريب والسيد / عبدلله باقشير