تحليل كود تحويل كمية اصناف بين المخازن

mahmoud nasr alhasany · أغسطس 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

جرب هدا

في جزء تسجيل التغيير في ورقة العمل 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 بواسطه محمد هشام.

mahmoud nasr alhasany · أغسطس 21

Cells(lastRow, 8).NumberFormat = "#,##0" ' تنسيق

عزرا انا اتعمدت أن أكرر العمود لتنسيق قيمة الكميه

فعزرا لانى اخطاءت فى كتابة تكرار الكود فى العمود ٨

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

هل ترى أن الكود يعمل بكفأئة ام يحتاج إلى تطوير أعمق واكثر

نريد أن استفادة من خبراتك إذا تفضلت فى مجال cod vba

تم تعديل أغسطس 21 بواسطه mahmoud nasr alhasany

mahmoud nasr alhasany · أغسطس 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

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

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

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

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

لو افترضنا ان

كود الصنف 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

جرب هدا التعديل

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

mahmoud nasr alhasany · أغسطس 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

يسعدنا أخي @mahmoud nasr alhasany أننا استطعنا مساعدتك.

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

بالتوفيق

تم تعديل أغسطس 23 بواسطه محمد هشام.

mahmoud nasr alhasany · أغسطس 23

اشكرك ا/ محمد هشام

انك جعلت من وقتك لحل مشاكلنا التى تواجهنا فى معادلة vba excel

اسأل الله أن يجعله في ميزان حسناتكم يارب العالمين

تسجيل الدخول

تحليل كود تحويل كمية اصناف بين المخازن

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

مقدمة

شرح خطوة بخطوة

الوظائف المساعدة

الميزات الرئيسية للكود

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

من فضلك سجل دخول لتتمكن من التعليق

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

Important Information