mahmoud nasr alhasany قام بنشر أغسطس 21 قام بنشر أغسطس 21 (معدل) مقدمة الغرض: يقوم الكود بتحويل كميات الأصناف بين المخازن المختلفة بناءً على بيانات موجودة في جدول 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 تم تعديل أغسطس 21 بواسطه mahmoud nasr alhasany
محمد هشام. قام بنشر أغسطس 21 قام بنشر أغسطس 21 (معدل) جرب هدا في جزء تسجيل التغيير في ورقة العمل Log هناك خطأ حيث يتم إدخال quantity مرتين في العمود الثامن Sub TransferQuantities() On Error GoTo ErrHandler ' تعريف المتغيرات Dim lastRow As Long Dim itemData As Object Dim i As Long Dim itemCode As String Dim quantityToTransfer As Long Dim itemName As String Dim sourceKey As String Dim targetKey As String Dim currentDate As Date Dim answer As VbMsgBoxResult Dim fa As Worksheet ' تحديد الورقة واستخدام المتغير Set fa = Sheets("Inventaire") ' تحديد آخر صف في ورقة المخزون lastRow = fa.Cells(fa.Rows.Count, "A").End(xlUp).Row ' ملء قاموس ببيانات الأصناف Set itemData = CreateObject("Scripting.Dictionary") For i = 2 To lastRow Dim key As String key = fa.Cells(i, 3).Value & "_" & fa.Cells(i, 2).Value ' مفتاح فريد: كود الصنف + اسم المخزن itemData.Add key, i ' تخزين رقم الصف المقابل للمفتاح Next i ' تأكيد عملية النقل قبل بدء التنفيذ answer = MsgBox("هل أنت متأكد من تنفيذ عملية النقل؟", vbYesNo, "تأكيد") If answer <> vbYes Then Exit Sub ' الحصول على التاريخ الحالي currentDate = Date ' التكرار على عناصر ListBox1 For i = 0 To ListBox1.ListCount - 1 itemCode = ListBox1.List(i, 0) itemName = ListBox1.List(i, 1) quantityToTransfer = Val(ListBox1.List(i, 2)) sourceKey = itemCode & "_" & Me.ComboBox1.Value targetKey = itemCode & "_" & Me.ComboBox2.Value ' التحقق من وجود الصنف في قائمة التحويل 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).Value = TextBox2.Value ' رقم الفاتورة .Cells(lastRowLog, 2).Value = TextBox5.Value ' التاريخ .Cells(lastRowLog, 3).Value = "تم تحويل " & quantityToTransfer & " من مخزن " & Me.ComboBox1.Value & " إلى مخزن " & Me.ComboBox2.Value .Cells(lastRowLog, 4).Value = Me.ComboBox1.Value .Cells(lastRowLog, 5).Value = Me.ComboBox2.Value .Cells(lastRowLog, 6).Value = itemCode .Cells(lastRowLog, 7).Value = itemName .Cells(lastRowLog, 8).Value = quantityToTransfer .Cells(lastRowLog, 9).Value = Environ("Username") End With Next i MsgBox "تمت عملية التحويل بنجاح. تم تسجيل التغييرات.", vbInformation Exit Sub ErrHandler: Dim errorLog As String errorLog = "وقت الحدوث: " & Now & vbNewLine & _ "الخطأ: " & Err.Description & vbNewLine & _ "رقم السطر: " & Erl & vbNewLine & _ "الإجراء: " & Err.Source & vbNewLine & _ "القيم: itemCode=" & itemCode & ", quantity=" & quantityToTransfer & ", sourceKey=" & sourceKey & ", targetKey=" & targetKey Open "ErrorLog.txt" For Append As #1 Print #1, errorLog Close #1 MsgBox "حدث خطأ أثناء عملية التحويل. يرجى التحقق من البيانات والمحاولة مرة أخرى.", vbCritical End Sub Private Sub UserForm_Initialize() 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 تم تعديل أغسطس 21 بواسطه محمد هشام. 1
mahmoud nasr alhasany قام بنشر أغسطس 21 الكاتب قام بنشر أغسطس 21 (معدل) Cells(lastRow, 8).NumberFormat = "#,##0" ' تنسيق عزرا انا اتعمدت أن أكرر العمود لتنسيق قيمة الكميه فعزرا لانى اخطاءت فى كتابة تكرار الكود فى العمود ٨ احسنت ا/ محمد هشام هل ترى أن الكود يعمل بكفأئة ام يحتاج إلى تطوير أعمق واكثر نريد أن استفادة من خبراتك إذا تفضلت فى مجال cod vba تم تعديل أغسطس 21 بواسطه mahmoud nasr alhasany
mahmoud nasr alhasany قام بنشر أغسطس 22 الكاتب قام بنشر أغسطس 22 الرجاء النظرة على الشيت وتعديل عليها اذا احتاجت تحسينات بخصوص او يوجد تكرارات ويمكن دمجها 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
محمد هشام. قام بنشر أغسطس 22 قام بنشر أغسطس 22 سوف احاول فقط تنظيم بعض الاكواد على حسب فهمي لها حاليا قم بتجربتها واخبرني بالنتيجة 1) Private Sub UserForm_Initialize() Dim f As Worksheet Dim OneRng As Variant Dim rng As Integer Dim d As Object Dim rw As Variant Dim i As Integer Dim lastRow As Long Dim ws As Worksheet Dim x As Variant Dim temp As Variant Dim rCrit1 As Integer, rCrit2 As Integer, rCrit3 As Integer Set f = Sheets("Inventaire") OneRng = f.Range("A2:G" & f.Cells(f.Rows.Count, 1).End(xlUp).Row).Value rng = UBound(OneRng, 2) ' ComboBox5 rCrit1 = 1 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit1)) = "" Next i rw = d.Keys tri rw, LBound(rw), UBound(rw) Me.ComboBox5.List = rw Me.ComboBox5.ListIndex = 0 ' ComboBox3 rCrit2 = 3 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 OneRng = f.Range("B2:G" & f.Cells(f.Rows.Count, 2).End(xlUp).Row).Value ' ComboBox1 rCrit3 = 1 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit3)) = "" Next i rw = d.Keys tri rw, LBound(rw), UBound(rw) Me.ComboBox1.List = rw Me.ComboBox1.ListIndex = 0 ' إعداد ComboBox3 rCrit2 = 2 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 ' إعداد TextBox5 و TextBox2 Set ws = Sheets("Log") Me.TextBox5.Value = Format(Date, "dd/mm/yyyy") lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row Me.TextBox2.Value = Format(Val(ws.Cells(lastRow, 1)) + 1, "00 00") ' إعداد ComboBox4 من العمود D Set ws = Sheets("Inventaire") lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row ComboBox4.Clear 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 Me.ComboBox5.Value = "*" CancelOperation = False End Sub بطرقة اخرى بعد فصل الكود المسؤول عن الفرز في دالة مستقلة SortArray و SortComboBox. Private Sub UserForm_Initialize() Dim f As Worksheet Dim OneRng As Variant Dim rng As Long Dim d As Object Dim rw As Variant Dim i As Long Dim rCrit1 As Long, rCrit2 As Long, rCrit3 As Long Dim lastRow As Long Dim ws As Worksheet Dim temp As String Dim j As Long ' إعداد ورقة العمل وتحديد النطاق Set f = Sheets("Inventaire") OneRng = f.Range("A2:G" & f.Cells(f.Rows.Count, "A").End(xlUp).Row).Value rng = UBound(OneRng, 2) 'غير مستخدم على ما اعتقد ' For i = 1 To UBound(OneRng): OneRng(i, 3) = OneRng(i, 3): Next i ' ComboBox5 rCrit1 = 1 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit1)) = "" Next i rw = d.Keys ' ترتيب ComboBox5 حسب العمود "اسم المخزن" (5) Call SortArray(rw) Me.ComboBox5.List = rw Me.ComboBox5.ListIndex = 0 ' ComboBox3 rCrit2 = 3 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 ' ComboBox1 OneRng = f.Range("B2:G" & f.Cells(f.Rows.Count, "B").End(xlUp).Row).Value rCrit3 = 1 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit3)) = "" Next i rw = d.Keys ' ترتيب ComboBox1 حسب العمود "اسم المخزن" (5) Call SortArray(rw) Me.ComboBox1.List = rw Me.ComboBox1.ListIndex = 0 ' ComboBox3 rCrit2 = 2 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 ' إعداد تاريخ اليوم Set ws = Sheets("Log") Me.TextBox5.Value = Format(Date, "dd/mm/yyyy") ' إعداد رقم الطلب Dim lr As Long lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row TextBox2.Value = Format(Val(ws.Cells(lr, 1)) + 1, "00 00") ' تعبئة ComboBox4 بالقيم الفريدة من العمود D Set ws = Sheets("Inventaire") lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row 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 (تصاعدي) Call SortComboBox(ComboBox4) ' تعيين قيمة افتراضية لـ ComboBox5 Me.ComboBox5.Value = "*" CancelOperation = False End Sub '**************************** Private Sub SortArray(ByRef arr As Variant) Dim i As Long, j As Long Dim temp As Variant For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If arr(i) > arr(j) Then temp = arr(i) arr(i) = arr(j) arr(j) = temp End If Next j Next i End Sub '************ Private Sub SortComboBox(ByRef cb As MSForms.ComboBox) Dim i As Long, j As Long Dim temp As String For i = 0 To cb.ListCount - 2 For j = i + 1 To cb.ListCount - 1 If cb.List(i) > cb.List(j) Then temp = cb.List(i) cb.List(i) = cb.List(j) cb.List(j) = temp End If Next j Next i End Sub Private Sub Search_Click() Dim ws As Worksheet Dim lastRow As Long Dim searchValue As String Dim x As Variant Dim i As Integer ' التحقق من وجود ورقة العمل On Error Resume Next Set ws = ThisWorkbook.Sheets("Transferts") On Error GoTo 0 If ws Is Nothing Then MsgBox " غير موجودة" & " " & "Transferts" & " ورقة العمل", vbCritical, "خطأ" Exit Sub End If lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row searchValue = TextBox2.Value ' مسح القوائم واستخدام حلقة For لتفريغ العناصر Dim controls As Variant controls = Array(ListBox1, ComboBox5, ComboBox2, ComboBox6, ComboBox3, ComboBox4, TextBox1) For i = LBound(controls) To UBound(controls) If TypeOf controls(i) Is MSForms.ListBox Then controls(i).Clear ElseIf TypeOf controls(i) Is MSForms.ComboBox Then controls(i).Clear ElseIf TypeOf controls(i) Is MSForms.TextBox Then controls(i).Value = "" End If Next i searchValue = TextBox2.Value x = Application.Match(Val(searchValue), ws.Columns(1), 0) If Not IsError(x) Then TextBox5.Value = ws.Cells(x, 2).Value ' عرض التاريخ ComboBox5.Value = ws.Cells(x, 4).Text ' عرض كود المخزن المحول منه ComboBox1.Value = ws.Cells(x, 5).Text ' عرض اسم المخزن المحول منه ComboBox6.Value = ws.Cells(x, 6).Text ' عرض كود المخزن المحول اليه ComboBox2.Value = ws.Cells(x, 7).Text ' عرض اسم المخزن المحول اليه Me.ListBox1.AddItem ws.Cells(x, 8) ' عرض كود الصنف Me.ListBox1.List(ListBox1.ListCount - 1, 1) = ws.Cells(x, 9) ' عرض اسم الصنف Me.ListBox1.List(ListBox1.ListCount - 1, 2) = ws.Cells(x, 10) ' عرض الكمية End If Me.ListBox1.ColumnCount = 4 Me.ListBox1.ColumnWidths = "130;130;55" End Sub Private Sub CommandButton2_Click() '''''تعديل البيانات على الليست بوكس''''' ' التحقق من وجود ورقة العمل "Transferts" If Not WorksheetExists("Transferts") Then MsgBox " غير موجودة" & " " & "Transferts" & " ورقة العمل", vbCritical, "خطأ" Exit Sub End If ' التحقق من القيم الفارغة If ListBox1.ListIndex = -1 Or (ComboBox3.Value = "" And Me.TextBox1.Value = "") Then Exit Sub If ListBox1.ListIndex <> -1 Then ' التحقق من صحة البيانات If Not IsNumeric(TextBox1.Value) Then MsgBox "الكمية يجب أن تكون رقمًا." Exit Sub End If If ComboBox1.ListIndex = -1 Then MsgBox "يرجى اختيار المخزن الذي سيتم النقل منه." Exit Sub End If 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 Dim fromStore1 As Long, toStore2 As Long Dim itemCode As String, quantity As Long, newQuantity As Long Dim quantityDiff As Long invoiceNo = Val(TextBox2.Value) fromStore = ComboBox1.Value toStore = ComboBox2.Value fromStore1 = Val(stocktr.Value) toStore2 = Val(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, "J").Value quantityDiff = newQuantity + quantity wsSales.Cells(i, "J").Value = newQuantity wsSales.Cells(i, "M").Value = Now() ' تاريخ التعديل wsSales.Cells(i, "N").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, "G").Value If wsStock.Cells(j, "B").Value = fromStore Then wsStock.Cells(j, "G").Value = newQuantity + fromStore1 ElseIf wsStock.Cells(j, "B").Value = toStore Then wsStock.Cells(j, "G").Value = toStore2 - newQuantity ' تم التعديل هنا wsStock.Cells(j, "M").Value = Now() ' تاريخ التعديل wsStock.Cells(j, "N").Value = Environ("Username") ' اسم المستخدم End If Next j MsgBox "تم تعديل الفاتورة وإرجاع الكميات بنجاح" Else MsgBox "المرجوا تحديد الصف المراد تعديله", vbCritical, "" End If End Sub '********** 'Transferts دالة للتحقق من وجود ورقة العمل Function WorksheetExists(sheetName As String) As Boolean Dim ws As Worksheet On Error Resume Next Set ws = Worksheets(sheetName) On Error GoTo 0 WorksheetExists = Not ws Is Nothing End Function
mahmoud nasr alhasany قام بنشر أغسطس 22 الكاتب قام بنشر أغسطس 22 (معدل) احسنت ا/ محمد هشام ولاكن بالنسبة لتعديل كمية الصنف وارجاع الكمية المتبقية الى المخزن وخصمها من المخزن الاخر لو افترضنا ان كود الصنف 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 تم تعديل أغسطس 22 بواسطه mahmoud nasr alhasany
محمد هشام. قام بنشر أغسطس 22 قام بنشر أغسطس 22 جرب هدا التعديل Private Sub CommandButton2_Click() ' التحقق من وجود ورقة العمل "Transferts" If Not WorksheetExists("Log") Then MsgBox "غير موجودة" & " " & "Transferts" & " ورقة العمل", vbCritical, "خطأ" Exit Sub End If ' التحقق من القيم الفارغة If ListBox1.ListIndex = -1 Or (ComboBox3.Value = "" And Me.TextBox1.Value = "") Then Exit Sub If ListBox1.ListIndex <> -1 Then ' التحقق من صحة البيانات If Not IsNumeric(TextBox1.Value) Then MsgBox "الكمية يجب أن تكون رقمًا." Exit Sub End If If ComboBox1.ListIndex = -1 Then MsgBox "يرجى اختيار المخزن الذي سيتم النقل منه." Exit Sub End If 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 Dim fromStore1 As Long, toStore2 As Long Dim itemCode As String, quantity As Long, newQuantity As Long Dim quantityDiff As Long invoiceNo = Val(TextBox2.Value) fromStore = ComboBox1.Value toStore = ComboBox2.Value fromStore1 = Val(stocktr.Value) toStore2 = Val(stocktrr.Value) Set wsSales = Worksheets("Log") 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 quantity = wsSales.Cells(i, "J").Value ' الكمية الأصلية newQuantity = Val(TextBox1.Value) ' الكمية المعدلة quantityDiff = newQuantity - quantity ' الفرق بين الكمية الأصلية والمعدلة ' تعديل الكمية في سجل المبيعات wsSales.Cells(i, "J").Value = newQuantity wsSales.Cells(i, "M").Value = Now() ' تاريخ التعديل wsSales.Cells(i, "N").Value = Environ("Username") ' اسم المستخدم ' تحديث المخزون بناءً على الفرق في الكمية 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 MsgBox "تم تعديل الفاتورة وإرجاع الكميات بنجاح" Else MsgBox "المرجوا تحديد الصف المراد تعديله", vbCritical, "" End If End Sub 1
أفضل إجابة mahmoud nasr alhasany قام بنشر أغسطس 23 الكاتب أفضل إجابة قام بنشر أغسطس 23 (معدل) ' تحديث المخزون بناءً على الفرق في الكمية 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 تم تعديلة الى العكس السالب والموجب' لتنجح الفكرة شكرا ا/محمد هشام على المجهود الرائع تم تعديل أغسطس 23 بواسطه mahmoud nasr alhasany
محمد هشام. قام بنشر أغسطس 23 قام بنشر أغسطس 23 (معدل) يسعدنا أخي @mahmoud nasr alhasany أننا استطعنا مساعدتك. هذا مجرد اجتهاد مني لأنني بصراحة ليست لي فكرة مسبقة أو خبرة في مجال المحاسبة. لأنه بعيد كل البعد عن مجال عملي. بالتوفيق تم تعديل أغسطس 23 بواسطه محمد هشام. 2
mahmoud nasr alhasany قام بنشر أغسطس 23 الكاتب قام بنشر أغسطس 23 اشكرك ا/ محمد هشام انك جعلت من وقتك لحل مشاكلنا التى تواجهنا فى معادلة vba excel اسأل الله أن يجعله في ميزان حسناتكم يارب العالمين
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.