اضافة شرط اخر على الكود

[ابو نبأ]

السلام عليكم

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

وعندي اضافة

وحبيت ان تكون في مشاركة جديدة - حسب توجيهات المنتدى

الطلب هو   اضافة شرط اخر على الكود وهو  (الموقع) في شيت اسمه (تقرير منفصل)

كما في الملف المرفق

 

 

تقرير - حسب - الشهر - والشركة.xlsm

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

[محمد هشام.]

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

أخي @ابو نبأ الأمر بسيط جدا  وسأشرح لك خطوة بخطوة كيف تضيف شرطا جديدا  (مثل: موقع التحميل في العمود k) إلى الكود  بحيث يمكنك لاحقا تعديل أو إضافة أي شرط بنفس الطريقة

1) التحقق من أن العمود الجديد (k) ليس فارغا 

If Trim(WS.Cells(i, "M").Text) <> "" And _
   Trim(WS.Cells(i, "L").Text) <> "" And _
   Trim(WS.Cells(i, "K").Text) <> "" And _ <=====    (موقع التحميل) العمود الجديد 

2)  تعديل المفتاح M  ليشمل القيمة الجديدة  

m = Trim(WS.Cells(i, "M").Text) & "|" & Trim(WS.Cells(i, "L").Text)
& "|" & Trim(WS.Cells(i, "K").Text)

3) تعديل إخراج البيانات المفككة من المفتاح

 f = Split(k, "|")
            a = d(k)
            dest.Cells(r, 1).Resize(1, 7).Value = Array(f(0), f(1), f(2), a(0), a(1), a(2), a(3))

4) لا تنسى تعديل رؤوس الأعمدة في الصف الأول لتتناسب مع التغيير 

dest.Range("A1").Resize(1, 7).Value _
    = Array("الشهر", "اسم الشركة", "الموقع", "عدد النقلات", "مجموع المبلغ للسائق", "مجموع مبلغ العقد", "مجموع الكمية (طن)")

ليكون الكود النهائي بعد إظافة عمود موقع التحميل على الشكل التالي 

Option Explicit
Sub TEST2()
    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
        With dest.Range("A:G")
            .ClearContents
            .Borders.LineStyle = xlNone
        End With
    End If
    On Error GoTo 0
        
    dest.Range("A1").Resize(1, 7).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) <> "" And Trim(WS.Cells(i, "K").Text) <> "" Then
                    m = Trim(WS.Cells(i, "M").Text) & "|" & Trim(WS.Cells(i, "L").Text) & "|" & Trim(WS.Cells(i, "K").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, 7).Value = Array(f(0), f(1), f(2), a(0), a(1), a(2), a(3))
            r = r + 1
        Next k
        Call ShFormat(dest, "A:G")
        
        .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
'=======================================
Private Sub ShFormat(ByRef WS As Worksheet, ByVal Col As String)
    With WS
    .Activate
    Dim lastRow As Long
    lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
    
    With WS.Range("A1:G" & lastRow).Borders
        .LineStyle = xlDash: .Weight = xlThin: .ColorIndex = xlAutomatic
    End With
        .DisplayRightToLeft = True
        .Columns(Col).EntireColumn.AutoFit
        .Columns(Col).HorizontalAlignment = xlCenter
        .Columns(Col).VerticalAlignment = xlBottom
        .Range("E:G").NumberFormat = "0"
    End With
End Sub

ملاحظة : يمكنك تعطيل تنسيق الجدول النهائي بحذف أو تعليق هذا السطر  أو تعديله ليشمل أعمدة أكثر إذا زادت الأعمدة لاحقا

Call ShFormat(dest, "A:G")

 

تقرير - حسب - الشهر - والشركة -الموقعV2 .xlsm

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

[ابو نبأ]

تمام - الكود شغال - والامور حيل طيبة

تسلم - سهلت عليه العمل