تعديل على كود اعداد تقرير

[ابو نبأ]

السلام عليكم 

ممكن التعديل على الكود لغرض اعداد تقرير - وكما موضح بالملف المرفق

لتكون النتائج من الشيتين aaa  bbb

او اعداد كود جديد

 

تقرير من شيتين.xlsm

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

جرب هدا 

Sub test()
    Dim dest As Worksheet, WS As Worksheet
    Dim m As String, a As Variant, k As Variant
    Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
    Dim ShArr As Variant: ShArr = Array("aaa", "bbb")
    Dim i As Long, lr As Long, r As Long: r = 2

    With Application
        .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual
        
        On Error Resume Next
        Set dest = Sheets("التقرير")
        If dest Is Nothing Then Set dest = Sheets.Add: dest.Name = "التقرير" Else dest.Range("A:E").ClearContents
        On Error GoTo 0
        dest.Range("A1").Resize(1, 5).Value _
        = Array("الشهر", "عدد النقلات", "مجموع المبلغ للسائق", "مجموع مبلغ العقد", "مجموع الكمية (طن)")

        For Each WS In Sheets(ShArr)
            lr = WS.Cells(WS.Rows.Count, "M").End(xlUp).Row
            For i = 2 To lr
                m = Trim(WS.Cells(i, "M").Text)
                If m <> "" Then
                    If Not d.exists(m) Then d(m) = Array(0, 0, 0, 0)
                    a = d(m)
                    a(0) = a(0) + 1: a(1) = a(1) + tmp(WS.Cells(i, "S").Value)
                    a(2) = a(2) + tmp(WS.Cells(i, "U").Value): a(3) = a(3) + tmp(WS.Cells(i, "F").Value)
                    d(m) = a
                End If
            Next i
        Next WS

        For Each k In d.Keys
            a = d(k)
            dest.Cells(r, 1).Resize(1, 5).Value = Array(k, a(0), a(1), a(2), a(3))
            r = r + 1
        Next k
        .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic
    End With

    MsgBox "تم إعداد التقرير بنجاح", vbInformation
End Sub
Private Function tmp(x As Variant) As Double
    tmp = IIf(IsNumeric(x), x, 0)
End Function

 

تقرير من شيتين v2.xlsm

[ابو نبأ]

جزاك الله خير - تمام 100 %

 

ممكن اضافة فقرة اخرى - في عمود l اسم الشركة - ليكون التقرير حسب الشهر واسم الشركة 

الشهر والشركة.xlsm

تم تعديل مايو 1 بواسطه ابو نبأ

[محمد هشام.]

تفضل أخي 

Sub test()
    Dim dest As Worksheet, WS As Worksheet
    Dim m As String, a As Variant, k As Variant, f As Variant
    Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
    Dim ShArr As Variant: ShArr = Array("aaa", "bbb")
    Dim i As Long, lr As Long, r As Long: r = 2

    With Application
        .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual
        
        On Error Resume Next
        Set dest = Sheets("التقرير")
        If dest Is Nothing Then Set dest = Sheets.Add: dest.Name = "التقرير" Else dest.Range("A:F").ClearContents
        On Error GoTo 0
        dest.Range("A1").Resize(1, 6).Value _
        = Array("الشهر", "اسم الشركة", "عدد النقلات", "مجموع المبلغ للسائق", "مجموع مبلغ العقد", "مجموع الكمية (طن)")

        For Each WS In Sheets(ShArr)
            If WS.AutoFilterMode Then WS.AutoFilterMode = False

            lr = WS.Cells(WS.Rows.Count, "M").End(xlUp).Row
            For i = 2 To lr
                If Trim(WS.Cells(i, "M").Text) <> "" And Trim(WS.Cells(i, "L").Text) <> "" Then
                    m = Trim(WS.Cells(i, "M").Text) & "|" & Trim(WS.Cells(i, "L").Text)
                    
                    If Not d.exists(m) Then d(m) = Array(0, 0, 0, 0)
                    d(m) = Array(d(m)(0) + 1, d(m)(1) + tmp(WS.Cells(i, "S").Value), _
                    d(m)(2) + tmp(WS.Cells(i, "U").Value), d(m)(3) + tmp(WS.Cells(i, "F").Value))

                End If
            Next i
        Next WS
        For Each k In d.Keys
            f = Split(k, "|")
            a = d(k)
            dest.Cells(r, 1).Resize(1, 6).Value = Array(f(0), f(1), a(0), a(1), a(2), a(3))
            r = r + 1
        Next k

        .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic
    End With

    MsgBox "تم إعداد التقرير بنجاح", vbInformation
End Sub

Private Function tmp(x As Variant) As Double
    tmp = IIf(IsNumeric(x), x, 0)
End Function

 

الشهر والشركة.xlsm

[ابو نبأ]

تسلم 100 % - الكود شغال وحسب ما مطلوب

جزيت خيرا