حساب الاجمالي السعر * الكمية لكل الاعمدة بكود vba

[mohamadhaje]

السلام عليكم ورحمة الله وبركاته ارجو المساعزد في تصحيح الكود التالي ولكم جزيل الشكر

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ErrorHandler ' معالجة الأخطاء
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("فاتورة مبيعات ") ' عدّل الاسم إذا كان مختلفًا
    
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
    
    ' تحديث المعادلة فقط عند تعديل العمودين F أو E
    If Not Intersect(Target, ws.Columns("F:E")) Is Nothing Then
        Application.EnableEvents = False ' تعطيل الأحداث لمنع الحلقات
        ws.Range("G5:G" & LastRow).Formula = "=IF(AND(F5<>"""", E5<>""""), F5*E5, """")"
        Application.EnableEvents = True ' إعادة تمكين الأحداث
    End If

    Exit Sub

ErrorHandler:
    Application.EnableEvents = True ' تأكد من إعادة تمكين الأحداث في حالة حدوث خطأ
    MsgBox "حدث خطأ: " & Err.Description, vbExclamation
End Sub

طط.xlsm

[محمد هشام.]

جرب هدا

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim Lr As Long
   Dim WS As Worksheet:   Set WS = Sheets("فاتورة مبيعات")

    Lr = WS.Cells(WS.Rows.Count, "F").End(xlUp).Row

    Application.EnableEvents = False
    For Each tmp In Target
        If Not Intersect(tmp, WS.Columns("F")) Is Nothing Or Not Intersect(tmp, WS.Columns("E")) Is Nothing Then
            If tmp.Row <= Lr Then
                WS.Cells(tmp.Row, "G").Formula = "=IF(AND(F" & tmp.Row & "<>"""", E" & _
                tmp.Row & "<>""""), F" & tmp.Row & "*E" & tmp.Row & ", """")"
            End If
        End If
    Next tmp
    Application.EnableEvents = True
    Exit Sub

    Application.EnableEvents = True
End Sub

 او 

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ColArr As Long, a As Variant, i As Long
    Dim WS As Worksheet: Set WS = Me

    On Error GoTo SubApp
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    ColArr = WS.Columns("E:G").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    If Not Intersect(Target, WS.Range("E5:F" & ColArr)) Is Nothing Then
        a = WS.Range("E5:G" & ColArr).Value
          With WS
            For i = 1 To ColArr - 4
                If IsNumeric(a(i, 1)) And IsNumeric(a(i, 2)) Then
                    If Len(a(i, 1)) > 0 And Len(a(i, 2)) > 0 Then
                        a(i, 3) = a(i, 1) * a(i, 2)
                    Else
                        a(i, 3) = ""
                    End If
                Else
                    a(i, 3) = ""
                End If
            Next i
            .Range("E5:G" & ColArr).Value = a
        End With
    End If
SubApp:
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

طط.rar

 

النتيجة قيم طط.rar

تم تعديل يناير 4 بواسطه محمد هشام.

[mahmoud nasr alhasany]

بعد استاذنا الرائع / محمد هشام.

اولا هذا المجهود بعد فضل الله يرجع للاستاذ محمد هشام و الاستاذ / حسونة حسين لقد تعلمنا منهما الكثير اسأل الله ان يمن عليهم بالخير الكثير

هذا الكود VBA بدون ادخال صيغ حسابية فى ورقة العمل فى العمود G

وشرحها كالاتى

• تعطيل الأحداث: نمنع حدوث أي تغييرات أخرى أثناء تنفيذ الكود لتجنب التكرار اللانهائي.
• التحقق من الخلية المتغيرة: نتأكد من أن الخلية التي تم تغييرها تقع في العمودين F أو E وأنها ضمن نطاق البيانات.
• التحقق من صحة البيانات: نتأكد من أن القيم المدخلة في الخليتين F و E هي أرقام. إذا كانت القيم غير رقمية، يتم عرض رسالة خطأ للمستخدم.
• حساب المجموع الكلي: نقوم بضرب قيمة الكمية في سعر الوحدة ونضع النتيجة في العمود G.
• تحديد ورقة العمل: يتم تحديد الورقة التي تحتوي على البيانات التي تريد تطبيق التنسيق الشرطي عليها.
• تحديد النطاق: يتم تحديد النطاق الذي يحتوي على القيم التي سيتم تطبيق التنسيق الشرطي عليها. في هذا المثال، يتم تطبيق التنسيق على العمود G بدءًا من الصف الثاني وحتى آخر صف يحتوي على بيانات.
• حذف التنسيق الشرطي الحالي: يتم حذف أي تنسيق شرطي موجود مسبقًا على النطاق المحدد.
• إضافة تنسيق شرطي جديد: يتم إضافة شرط جديد حيث يتم تلوين الخلايا باللون الأحمر إذا كانت قيمتها أقل من صفر (أي سالبة).
• تخصيص التنسيق: يمكنك تغيير لون الخط، حجم الخط، الخط العريض، والمائل وغيرها من خصائص التنسيق حسب رغبتك.

 

Private Sub Worksheet_Change(ByVal Target As Range)
    ' تحديد ورقة العمل والعمود الأخير للبيانات
    Dim WS As Worksheet: Set WS = Sheets("فاتورة مبيعات")
    Dim Lr As Long: Lr = WS.Cells(WS.Rows.Count, "F").End(xlUp).Row

    ' تعطيل أحداث التغيير مؤقتًا لمنع التكرار اللانهائي
    Application.EnableEvents = False

    ' التحقق من أن الخلية المتغيرة تقع في العمودين F أو E
    If Not Intersect(Target, WS.Range("F:E")) Is Nothing Then
        ' التأكد من أن الصف المتغير ضمن نطاق البيانات
        If Target.Row <= Lr Then
            ' التحقق من أن القيم المدخلة هي أرقام
            If IsNumeric(Target.Value) And IsNumeric(WS.Cells(Target.Row, "E").Value) Then
                ' حساب المجموع الكلي وتعيينه في الخلية المناسبة
                WS.Cells(Target.Row, "G").Value = Target.Value * WS.Cells(Target.Row, "E").Value
          Call staining_negative_cells
            Else
                MsgBox "الرجاء إدخال قيم رقمية صحيحة في عمودي الكمية والسعر."
            End If
        End If
    End If

    ' إعادة تمكين أحداث التغيير
    Application.EnableEvents = True
End Sub
          
          
Sub staining_negative_cells()
    Dim WS As Worksheet
    Set WS = Sheets("فاتورة مبيعات")  ' استبدل باسم الورقة التي تريدها

    ' تحديد النطاق الذي تريد تطبيق التنسيق الشرطي عليه
    With WS.Range("G2:G" & WS.Cells(WS.Rows.Count, "G").End(xlUp).Row)
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:="0"
        With .FormatConditions(1).Font
            .Color = -16776961  ' لون أحمر
            .Bold = True
        End With
    End With
End Sub

 

 

طط.rar

تم تعديل يناير 3 بواسطه mahmoud nasr alhasany