mahmoud nasr alhasany

اشكرك ا/ محمد هشام انك جعلت من وقتك لحل مشاكلنا التى تواجهنا فى معادلة vba excel اسأل الله أن يجعله في ميزان حسناتكم يارب العالمين

' تحديث المخزون بناءً على الفرق في الكمية lastRowStock = wsStock.Cells(wsStock.Rows.Count, "A").End(xlUp).Row For j = 2 To lastRowStock If wsStock.Cells(j, "B").Value = fromStore Then wsStock.Cells(j, "G").Value = wsStock.Cells(j, "G").Value + quantityDiff ' إضافة أو طرح الفرق من المخزن الأصلي ElseIf wsStock.Cells(j, "B").Value = toStore Then wsStock.Cells(j, "G").Value = wsStock.Cells(j, "G").Value - quantityDiff ' خصم الفرق من المخزن الآخر wsStock.Cells(j, "M").Value = Now() ' تاريخ التعديل wsStock.Cells(j, "N").Value = Environ("Username") ' اسم المستخدم End If Next j End If Next i 'تم تعديلة الى العكس السالب والموجب' ' تحديث المخزون بناءً على الفرق في الكمية lastRowStock = wsStock.Cells(wsStock.Rows.Count, "A").End(xlUp).Row For j = 2 To lastRowStock If wsStock.Cells(j, "B").Value = fromStore Then wsStock.Cells(j, "G").Value = wsStock.Cells(j, "G").Value - quantityDiff ' إضافة أو طرح الفرق من المخزن الأصلي ElseIf wsStock.Cells(j, "B").Value = toStore Then wsStock.Cells(j, "G").Value = wsStock.Cells(j, "G").Value + quantityDiff ' خصم الفرق من المخزن الآخر wsStock.Cells(j, "M").Value = Now() ' تاريخ التعديل wsStock.Cells(j, "N").Value = Environ("Username") ' اسم المستخدم End If Next j End If Next i تم تعديلة الى العكس السالب والموجب' لتنجح الفكرة شكرا ا/محمد هشام على المجهود الرائع

احسنت ا/ محمد هشام ولاكن بالنسبة لتعديل كمية الصنف وارجاع الكمية المتبقية الى المخزن وخصمها من المخزن الاخر لو افترضنا ان كود الصنف 100 بمخزن 1 ورصيده 55 كود الصنف 100 بمخزن 2 ورصيده 50 لو افترضنا اننا تم صرف برقم سريال 23 كود صنف 100 كمية 5 ك من مخزن 1 الى مخزن 2 وتم تعديل الكمية الى 2 ك المفروض يقوم بأرجاع الكمية المتبقية 3 الى مخزن 1 ليكون 58 ومخزن 2 ليكون 47 ولاكن الذى يتحقق العكس فأنة يقوم بخصم واضافة الكمية 2 ك الى المخزنين ليكون مخزن 1 رصيده 57 بدل 58 ومخزن 2 رصيده 48 بدل 47 هل يوجد طريقة تقوم بخصم واضافة الكمية المرحلة بدل الكمية المعدلة برنامج امين المخزن2022.xlsm

الرجاء النظرة على الشيت وتعديل عليها اذا احتاجت تحسينات بخصوص او يوجد تكرارات ويمكن دمجها Private Sub UserForm_Initialize() Set f = Sheets("Inventaire") OneRng = f.Range("A2:G" & f.[A65000].End(xlUp).Row).Value rng = UBound(OneRng, 2) ' تنسيق عمود اسم الصنف For i = 1 To UBound(OneRng): OneRng(i, 3) = OneRng(i, 3): Next i ' 4اسم المخزن rCrit1 = 1 'كود rCrit2 = 3 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit1)) = "" Next i rw = d.Keys ' Sort Combobox 1 Colmuns "اسم المخزن" (5) tri rw, LBound(rw), UBound(rw) Me.ComboBox5.List = rw: Me.ComboBox5.ListIndex = 0 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit2)) = "" Next i rw = d.Keys Me.ComboBox3.List = rw: Me.ComboBox3.ListIndex = 0 ' Me.ComboBox4.List = Me.ComboBox3.ListIndex ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Set f = Sheets("Inventaire") OneRng = f.Range("B2:G" & f.[B65000].End(xlUp).Row).Value rng = UBound(OneRng, 2) ' تنسيق عمود اسم الصنف For i = 1 To UBound(OneRng): OneRng(i, 3) = OneRng(i, 3): Next i ' 4اسم المخزن rCrit3 = 1 'كود rCrit2 = 2 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit3)) = "" Next i rw = d.Keys ' Sort Combobox 1 Colmuns "اسم المخزن" (5) tri rw, LBound(rw), UBound(rw) Me.ComboBox1.List = rw: Me.ComboBox1.ListIndex = 0 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit2)) = "" Next i rw = d.Keys Me.ComboBox3.List = rw: Me.ComboBox3.ListIndex = 0 ' Me.ComboBox4.List = Me.ComboBox3.ListIndex ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim ws As Worksheet Dim lr As Integer Set ws = Sheets("Log") Me.TextBox5.Value = Format(Date, "dd/mm/yyyy") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row ' NoCommande = Format(Val(Ws.Cells(Lr, 1)) + 1, "00 00") TextBox2 = Format(Val(ws.Cells(lr, 1)) + 1) ' Label24 = " تم التسجيل بواسطة المستخدم " & Sheet5.Range("A" & Rows.Count).End(xlUp) & " بتاريخ " & Sheet5.Range("b" & Rows.Count).End(xlUp) Dim lastRow As Long Set ws = Worksheets("Inventaire") ' ابحث عن الصف الأخير الذي يحتوي على البيانات في العمودين B وC lastRow = ws.Cells(Rows.Count, "D").End(xlUp).Row ' قم بتعبئة ComboBox3 بقيم فريدة من العمود B ' قم بملء ComboBox4 بقيم فريدة من العمود C For i = 2 To lastRow If ws.Cells(i, "D").Value <> ws.Cells(i - 1, "D").Value Then ComboBox4.AddItem ws.Cells(i, "D").Value End If Next i 'فرز ComboBox4 (تصاعدي) ComboBox4.ListIndex = -1 'إعادة تعيين الاختيار For i = 0 To ComboBox4.ListCount - 2 For j = i + 1 To ComboBox4.ListCount - 1 If ComboBox4.List(i) > ComboBox4.List(j) Then temp = ComboBox4.List(i) ComboBox4.List(i) = ComboBox4.List(j) ComboBox4.List(j) = temp End If Next j Next i '' ... كود الفرز 'For i = 2 To lastRow ' If ws.Cells(i, "C").Value <> ws.Cells(i - 1, "C").Value Then ' ComboBox4.AddItem ws.Cells(i, "C").Value ' End If 'Next i Me.ComboBox5 = "*" CancelOperation = False End Sub برنامج امين المخزن.xlsm

Cells(lastRow, 8).NumberFormat = "#,##0" ' تنسيق عزرا انا اتعمدت أن أكرر العمود لتنسيق قيمة الكميه فعزرا لانى اخطاءت فى كتابة تكرار الكود فى العمود ٨ احسنت ا/ محمد هشام هل ترى أن الكود يعمل بكفأئة ام يحتاج إلى تطوير أعمق واكثر نريد أن استفادة من خبراتك إذا تفضلت فى مجال cod vba

مقدمة الغرض: يقوم الكود بتحويل كميات الأصناف بين المخازن المختلفة بناءً على بيانات موجودة في جدول Excel بالمخزون "Inventaire" الفورم يحتوى على userform textbox and Combobox and listbox هذا الكود في VBA مخصص لإدارة عمليات نقل المنتجات بين مخازن مختلفة في جدول بيانات إكسيل. يقوم بتحديث كميات المنتجات في المخازن المصدر والهدف، ويسجل تفاصيل عملية النقل في ورقة عمل أخرى. وهى"Log" شرح خطوة بخطوة تعريف المتغيرات: يتم تعريف مجموعة من المتغيرات لتخزين البيانات المختلفة التي ستستخدمها أثناء عملية التحويل مثل: lastRow: لتحديد آخر صف في ورقة المخزون. itemData: وهو قاموس لتخزين بيانات الأصناف بشكل سريع وفعال. itemCode, quantity, sourceKey, targetKey: لتخزين معلومات عن الصنف والكمية والمخازن المصدر والهدف. ملء القاموس: يتم ملء القاموس itemData ببيانات الأصناف من ورقة المخزون. يتم إنشاء مفتاح فريد لكل صنف ومخزن لسهولة الوصول إليه. التكرار على عناصر ListBox1: يتم التكرار على العناصر الموجودة في ListBox1 والتي تمثل الأصناف التي سيتم تحويلها. التحققات: التحقق من وجود الصنف في قائمة التحويل: يتم التأكد من أن الصنف المراد تحويله موجود بالفعل في قائمة التحويل. التحقق من صحة البيانات: يتم التأكد من أن الكمية المراد تحويلها موجبة. التحقق من وجود الصنف في المخازن: يتم التأكد من وجود الصنف في كلا المخزنين المصدر والهدف. التحقق من كافية الكمية: يتم التأكد من أن الكمية المتاحة في المخزن المصدر كافية للعملية. التحقق من الكمية المتاحة: تم إضافة شرط للتحقق من أن الكمية المراد تحويلها لا تتجاوز الكمية المتاحة في المخزن المصدر. معالجة حالة عدم وجود المخزن الهدف: إذا لم يوجد المخزن الهدف، يمكنك إعطاء المستخدم خيار إنشاء المخزن الجديد أو إلغاء العملية. التحقق من وجود بيانات في ListBox1: للتأكد من وجود أصناف يتم تحويلها. تحديد آخر صف في ورقة المخزون: لتحديد نطاق البحث عن الأصناف. التكرار على عناصر ListBox1: لكل صنف، يتم البحث في ورقة المخزون عن الصفوف التي تطابق كود الصنف والمخزن. تحديث الكميات: يتم زيادة أو نقصان الكمية في المخزن المستهدف والمخزن المصدر على الترتيب. تحديث الكميات: يتم تحديث كميات الصنف في المخازن المصدر والهدف وفقًا للكمية المحولة. تسجيل التغيير: يتم تسجيل تفاصيل عملية التحويل في جدول السجل (ورقة "Log"). معالجة الأخطاء: يتم استخدام كتلة On Error GoTo لمعالجة أي أخطاء قد تحدث أثناء عملية التحويل وتسجيلها في ملف سجل. الوظائف المساعدة IsInList: هذه الوظيفة تستخدم للتحقق من وجود قيمة معينة في قائمة. UpdateInventory: هذه الوظيفة تستخدم لتحديث كميات المخزون في جدول البيانات. LogChange: هذه الوظيفة تستخدم لتسجيل تفاصيل عملية التحويل في جدول السجل. الميزات الرئيسية للكود مرونة: يمكن تخصيص الكود بسهولة لتلبية احتياجات مختلفة. كفاءة: يستخدم القاموس لتسريع عملية الوصول إلى البيانات. معالجة الأخطاء: يتضمن آلية لمعالجة الأخطاء وتسجيلها. واجهة مستخدم: يوفر واجهة مستخدم بسيطة لتسهيل عملية التحويل. هذا شرح كود عملية التحويل كمية صنف بين المخازن فهل الكود جيدا ام يريد اضافات علية Sub TransferQuantities() On Error GoTo ErrHandler ' تعريف المتغيرات Dim lastRow As Long Dim itemData As Object Set itemData = CreateObject("Scripting.Dictionary") ' تحديد آخر صف في ورقة المخزون (افتراضًا "Inventaire") With Sheets("Inventaire") lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row End With ' ملء قاموس ببيانات الأصناف Dim i As Long For i = 2 To lastRow Dim key As String key = .Cells(i, 3).value & "_" & .Cells(i, 2).value ' مفتاح فريد: كود الصنف + اسم المخزن itemData.Add key, i ' تخزين رقم الصف المقابل للمفتاح Next i Dim itemCode As Long Dim quantityToTransfer As Long Dim sourceKey As String Dim targetKey As String ' التكرار على عناصر ListBox1 For i = 0 To ListBox1.ListCount - 1 itemCode = Val(ListBox1.List(i, 0)) itemName = Val(ListBox1.List(i, 1)) quantity = Val(ListBox1.List(i, 2)) sourceKey = itemCode & "_" & Me.ComboBox1.value targetKey = itemCode & "_" & Me.ComboBox2.value If CancelOperation Then Exit For ' الحصول على التاريخ الحالي Dim currentDate As Date currentDate = Date ' التحقق من التاريخ If TextBox5.Value > currentDate Then MsgBox "التاريخ الذي أدخلته مستقبلي. يرجى إدخال تاريخ صحيح.", vbCritical Exit Sub End If ' التحقق من وجود الصنف في قائمة التحويل If Not IsInList(itemCode, ListBox1) Then MsgBox "الصنف " & itemCode & " غير موجود في قائمة التحويل.", vbCritical Exit Sub End If ' التحقق من صحة البيانات If quantityToTransfer <= 0 Then MsgBox "الكمية يجب أن تكون موجبة.", vbCritical Exit Sub End If ' التحقق من وجود الصنف في المخازن المصدر If Not itemData.Exists(sourceKey) Then MsgBox "الصنف " & itemCode & " غير موجود في المخزن المصدر " & Me.ComboBox1.value, vbCritical Exit Sub End If If Not itemData.Exists(targetKey) Then MsgBox "الصنف " & itemCode & " غير موجود في المخزن الهدف " & Me.ComboBox2.value, vbCritical Exit Sub End If ' التحقق من الكمية المتاحة في المخزن المصدر If fa.Cells(itemData(sourceKey), 7).value < quantityToTransfer Then MsgBox "الكمية المتاحة في المخزن المصدر غير كافية.", vbCritical Exit Sub End If ' تحديث الكميات On Error GoTo HandleError fa.Cells(itemData(sourceKey), 7).value = fa.Cells(itemData(sourceKey), 7).value - quantityToTransfer fa.Cells(itemData(targetKey), 7).value = fa.Cells(itemData(targetKey), 7).value + quantityToTransfer On Error GoTo 0 ' تسجيل التغيير With Sheets("Log") lastRowLog = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 .Cells(lastRowLog, 1) = TextBox2.value ' رقم الفاتورة .Cells(lastRowLog, 2) = TextBox5.value ' التاريخ .Cells(lastRowLog, 3) = "تم تحويل " & " من مخزن " & Me.ComboBox1.Value & " إلى مخزن " & Me.ComboBox2.Value .Cells(lastRowLog, 4) = Me.ComboBox1.value .Cells(lastRowLog, 5) = Me.ComboBox2.value .Cells(lastRowLog, 6) = itemCode .Cells(lastRowLog, 7) = itemName .Cells(lastRowLog, 8) = quantity .Cells(lastRowLog, 8) = quantity .Cells(lastRowLog, 9) = Environ("Username") End With Next i Dim answer As VbMsgBoxResult answer = MsgBox("هل أنت متأكد من تنفيذ عملية النقل؟", vbYesNo, "تأكيد") If answer = vbYes Then ' تنفيذ عملية النقل End If MsgBox "تمت عملية التحويل بنجاح. تم تسجيل التغييرات.", vbInformation Exit Sub ' تسجيل الخطأ في ملف سجل ErrHandler: Dim errorLog As String errorLog = "وقت الحدوث: " & Now & vbNewLine & _ "الخطأ: " & Err.Description & vbNewLine & _ "رقم السطر: " & Erl & vbNewLine & _ "الإجراء: " & Err.Source & vbNewLine & _ "الوظيفة: " & CurrentProcedure & vbNewLine & _ "القيم: itemCode=" & itemCode & ", quantity=" & quantity & ", sourceKey=" & sourceKey & ", targetKey=" & targetKey Open "ErrorLog.txt" For Append As #1 Print #1, errorLog Close #1 MsgBox "حدث خطأ أثناء عملية التحويل. يرجى التحقق من البيانات والمحاولة مرة أخرى.", vbCritical End Sub Private Sub UserForm_Initialize() ' ... (تهيئة عناصر UserForm) CancelOperation = False End Sub Private Sub cmdCancel_Click() CancelOperation = True Me.Hide End Sub '' وظيفة للتحقق من وجود الصنف في المخزن Function IsInList(itemValue As Variant, myList As Object) As Boolean Dim i As Long For i = 0 To myList.ListCount - 1 If myList.List(i, 0) = itemValue Then IsInList = True Exit Function End If Next i IsInList = False End Function Function IsItemInInventory(itemCode As Long, warehouseName As String) As Boolean ' التحقق من وجود الصنف في قائمة التحويل If Not IsInList(itemCode, ListBox1) Then MsgBox "الصنف " & itemCode & " غير موجود في قائمة التحويل.", vbCritical Exit Function End If End Function

تم ايجاد المشكلة بحمدلله الخاص بتعديل الكمية وارجاعها للمخزنين سواء خصم اوزيادة فى احداهما يوجد كودين Private Sub CommandButton2_Click() ' ... 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 Dim quantityDiff As Long 'رقم الفاتورة invoiceNo = Val(TextBox2.Value) ' ComboBox1 المخزون الاول fromStore = ComboBox1.Value ' ComboBox2 المخزون الثانى toStore = ComboBox2.Value ' ComboBox1 رصيد المخزون الاول fromStore1 = stocktr.Value ' ComboBox2 رصيد المخزون الثانى toStore2 = stocktrr.Value 'شيت مبيعات Set wsSales = Worksheets("Transferts") 'شيت المخزون Set wsStock = Worksheets("Inventaire") 'ابحث عن الفاتورة في ورقة المبيعات lastRowSales = wsSales.Cells(wsSales.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRowSales If wsSales.Cells(i, "A").Value = invoiceNo Then ' احصل على الكمية الجديدة من المستخدم (مثال: عن طريق TextBox) newQuantity = Val(TextBox1.Value) ' احسب فرق الكمية quantity = wsSales.Cells(i, "H").Value quantityDiff = newQuantity + quantity ' قم بتحديث الكمية في ورقة المبيعات wsSales.Cells(i, "H").Value = newQuantity wsSales.Cells(i, "k").Value = Now() ' تاريخ التعديل wsSales.Cells(i, "l").Value = Environ("Username") ' اسم المستخدم End If Next i ' ابحث عن الفاتورة في ورقة المخزون lastRowStock = wsStock.Cells(wsStock.Rows.Count, "A").End(xlUp).Row For j = 2 To lastRowStock If wsStock.Cells(j, "A").Value = fromStore Then ' احصل على الكمية الجديدة من المستخدم (مثال: عن طريق TextBox) newQuantity = Val(TextBox1.Value) quantity = wsStock.Cells(j, "D").Value quantityDiff = newQuantity - quantity ' قم بتحديث الكمية في ورقة المبيعات wsStock.Cells(j, "D").Value = newQuantity + fromStore1 ' تحديث الكميات في المخزون ' ... (نفس الكود السابق لإرجاع الكميات) ElseIf wsStock.Cells(j, "A").Value = toStore Then ' احصل على الكمية الجديدة من المستخدم (مثال: عن طريق TextBox) newQuantity = Val(TextBox1.Value) ' احسب فرق الكمية quantity = wsStock.Cells(j, "D").Value quantityDiff = newQuantity + quantity ' قم بتحديث الكمية في ورقة المبيعات wsStock.Cells(j, "D").Value = toStore2 - newQuantity wsStock.Cells(j, "J").Value = Now() ' تاريخ التعديل wsStock.Cells(j, "K").Value = Environ("Username") ' اسم المستخدم End If Next j MsgBox "تم تعديل الفاتورة وإرجاع الكميات بنجاح" End Sub 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 Dim quantityDiff As Long invoiceNo = Val(TextBox2.Value) ' ComboBox1 المخزون الاول fromStore = ComboBox1.Value ' ComboBox1 المخزون الاول toStore = ComboBox2.Value ' ComboBox1 قيمة المخزون الاول fromStore1 = stocktr.Value ' ComboBox2 قيمة المخزون الثانى toStore2 = stocktrr.Value Set wsSales = Worksheets("Transferts") Set wsStock = Worksheets("Inventaire") lastRowSales = wsSales.Cells(wsSales.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRowSales If wsSales.Cells(i, "A").Value = invoiceNo Then newQuantity = Val(TextBox1.Value) quantity = wsSales.Cells(i, "H").Value quantityDiff = newQuantity + quantity wsSales.Cells(i, "H").Value = newQuantity wsSales.Cells(i, "k").Value = Now() ' تاريخ التعديل wsSales.Cells(i, "l").Value = Environ("Username") ' اسم المستخدم End If Next i lastRowStock = wsStock.Cells(wsStock.Rows.Count, "A").End(xlUp).Row For j = 2 To lastRowStock quantity = wsStock.Cells(j, "D").Value If wsStock.Cells(j, "A").Value = fromStore Then wsStock.Cells(j, "D").Value = newQuantity + fromStore1 ElseIf wsStock.Cells(j, "A").Value = toStore Then wsStock.Cells(j, "D").Value = toStore2 - newQuantity ' تم التعديل هنا wsStock.Cells(j, "J").Value = Now() ' تاريخ التعديل wsStock.Cells(j, "K").Value = Environ("Username") ' اسم المستخدم End If Next j MsgBox "تم تعديل الفاتورة وإرجاع الكميات بنجاح" End Sub امين مخزن4.xlsm

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

هذا هوالملف الخاص بالتعديل يوجد به مشكلة تحديث ارجاع كمية الى المخزن المحول منه فعال اما ارجاع الكميه من المخزن المحول الية غير مظبوط مثال شيت المخزون Set wsStock = Worksheets("Inventaire") مخزن1 الكمية المفترض 92 مخزن2 الكمية المفترض 75 والكمية المسترجعة من شيت المبيعات Set wsStock = Worksheets("Transferts") الكمية هى 5 الى شيت المخزون Set wsStock = Worksheets("Inventaire") بعد تحديث المخزون يكون مخزن1 الكمية المفترض 97 مخزن2 الكمية المفترض 70 ولاكن النتيجة فى شيت المخزون غير كدة بعد تحديث المخزون يكون مخزن1 الكمية المفترض 97 مخزن2 الكمية المفترض 80 تجد المشكلة فى الكمية المسترجعة فى مخزن2 تكون 70 بدل ان تزيد الكمية 5 لتكون 80 من اصل الكمية 75 امين مخزن3.xlsm

بخصوص التعديل لم يتم حل المشكلة 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 تم عمل المطلوب جرب هذا الكود