فرز وجمع

[alihgrvdad123]

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

عندي ملف يحتوي على بيانات

المطلوب فرز وجمع كل شعبة 

وحسب الملف المرفق

فرز وجمع.xlsx

[محمد حسن المحمد]

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

أرجو أن تكون النتيجة مقبولة باستخدام Pivot table

فرز وجمع.xlsx

[alihgrvdad123]

ممكن كود

 

[محمد حسن المحمد]

السلام عليكم

أرجو أن يكون مناسباً

Sub Sort_Sum()
Application.ScreenUpdating = False
    Sheets("البيانات").Range("Data").Copy
    Sheets("فرز وجمع").Range("Sort_Sum[اسم الموظف]").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("فرز وجمع").ListObjects("Sort_Sum").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("فرز وجمع").ListObjects("Sort_Sum").Sort.SortFields.Add Key:=Range("Sort_Sum[الشعبة]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("فرز وجمع").ListObjects("Sort_Sum").Sort.SortFields.Add Key:=Range("Sort_Sum[المبلغ]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("فرز وجمع").ListObjects("Sort_Sum").Sort.SortFields.Add Key:=Range("Sort_Sum[اسم الموظف]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("فرز وجمع").ListObjects("Sort_Sum").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("K2").FormulaR1C1 = _
        "=SUMIF(Sort_Sum[[الشعبة]:[المبلغ]],[@الشعبة],Sort_Sum[المبلغ])"
    Range("K2").AutoFill Destination:=Range("شعب[المبلغ]")
    Range("a1").Select
    Calculate
 Application.ScreenUpdating = True
End Sub

 

 

فرز وجمع.xlsm

[alihgrvdad123]

جزيت خيرا

تسلم

هو المطلوب

[lionheart]

Sub Test()
    Const sOutput As String = "Output"
    Dim shp As Shape, m As Long, r As Long, n As Long
    Application.ScreenUpdating = False
        Application.DisplayAlerts = False
            On Error Resume Next: Sheets(sOutput).Delete: On Error GoTo 0
        Application.DisplayAlerts = True
        Sheets(1).Copy , Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = sOutput
        With Sheets(sOutput)
            For Each shp In .Shapes
                shp.Delete
            Next shp
            .AutoFilterMode = False
            If .FilterMode = True Then .ShowAllData
            m = .Cells(Rows.Count, 1).End(xlUp).Row
            .Range("A1:H" & m).Sort Key1:=.Range("G1:G" & m), Order1:=xlAscending, Header:=xlYes
            r = 2
            Do Until .Cells(r, 7).Value = Empty
                If r = 2 Then n = r
                If .Cells(r, 7).Value <> .Cells(r + 1, 7).Value Then
                    .Rows(r + 1).Insert Shift:=xlDown
                    .Cells(r + 1, 7).Value = "Total"
                    .Cells(r + 1, 8).Formula = "=SUM(H" & n & ":H" & r & ")"
                    With .Cells(r + 1, 7).Resize(, 2)
                        .Font.Color = vbWhite
                        .Interior.Color = RGB(55, 86, 36)
                    End With
                    r = r + 1
                    n = r + 1
                End If
                r = r + 1
            Loop
        End With
    Application.ScreenUpdating = True
End Sub

 

[محمد حسن المحمد]

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

أخي الكريم @lionheart جزاكم الله خيراً ..أحسنتم كود رائع لاستخلاص النتائج بواسطة كود Pivot Table

تقبل تحياتي العطرة لشخصكم الكريم

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