تعديل على معادلة لعمل الوصل أو ابدال المعادلات بكود مشكورين

[ابوعبدالواجد]

السلام عليكم - حفظكم الله

يرجى الاطلاع على المعادلات الموجودة بشيت الوصل لوجود  نقص أو خلل فيها 

واكون ممنون وشاكر  اذا ابدلت المعدلات بكود 

جزيتم خيرا

تصحيح معادلة او عمل كود بدل المعادلات.rar

[ياسر خليل أبو البراء]

وعليكم السلام

جرب الكود التالي

Sub Test()
    Dim ws      As Worksheet
    Dim sh      As Worksheet
    Dim arr     As Variant
    Dim temp    As Variant
    Dim i       As Long
    Dim j       As Long
    Dim c       As Long
    Dim b       As Boolean
    Dim t       As Double
    
    Set ws = Sheets("السجل")
    Set sh = Sheets("وصل")
    arr = ws.Range("A4:J" & ws.Cells(Rows.Count, 1).End(xlUp).Row).Value
    ReDim temp(1 To UBound(arr, 1), 1 To 4)
    sh.Range("A4:D" & Rows.Count).ClearContents

    For i = LBound(arr, 1) To UBound(arr, 1)
        If arr(i, 2) = sh.Range("A2").Value Then
            If b = False Then
                sh.Range("B2").Value = arr(i, 3)
                sh.Range("G4").Value = arr(i, 8)
                b = True
            End If
            
            j = j + 1
            For c = 4 To 7
                temp(j, c - 3) = arr(i, c)
            Next c
            
            t = Application.WorksheetFunction.Sum(t, arr(i, 9))
        End If
    Next i
    
    If j > 0 Then
        sh.Range("F4").Value = t
        sh.Range("A4").Resize(j, UBound(temp, 2)).Value = temp
    End If
End Sub

 

[ابوعبدالواجد]

جزيت خيرا - جزيت خيرا

مشكورين

تمام