ملخص بيانات في شيت اخر

[محمد عبد الناصر]

في الملف المرفق يوجد في شيت "الاعمال" مجموعة اعمال مثل الحفر و الخرسانة العادية والخرسانة المسلحة 

اريد ان يقوم بعمل استعداء اجمالي كل بند  في كل مبنى فمثلا 

المبنى1 بند الحفر والردم = 1000      وفي المبنى2 بند الحفر والردم = 1500 

الملف المرفق يوضح المطلوب .. انتبه من فضلك , طالما انك تريد طلبك بالأكواد .فكان لزاما عليك رفع الملف بإمتداد Xlsm ... فقد تـــم اعادة رفع الملف بهذا الإمتداد

ملحص.xlsm

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

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

أخي الكريم هل هذا ما تريد الوصول إليه 

فإن لم يكن يرجى التوضيح اكثر

تم استخدام الدالة Sumif للوصول إلى النتائج لكن بعد إلغاء دمج الخلايا في ملف البيانات

كما يلي:

ملحص.xlsx

[محمد عبد الناصر]

شكرا لمجهودك بس اول حاجه مش هينفع اعمل الغاء دمج الخلايا لان عايز اطبقها اوتوماتك على اكتر من 500 بند وفي كذا ملف مختلف انا محتاج كود ينفذ المطلوب 
 

[عبدالفتاح في بي اكسيل]

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

لذلك ينصح  العمل  على  خلايا  غير  مدمجة وتوجد مقالات  كثيرة  في  الانترنت  حول  خطورة الخلايا  المدمجة  التي  تسبب  مشاكل  كبيرة .

[lionheart]

Sub Test()
    Dim ws As Worksheet, sh As Worksheet, rRange As Range, rCell As Range, rng As Range, t As Double, iRow As Long, r As Long, c As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(2)     'Tasks
        Set sh = ThisWorkbook.Worksheets(1)     'Summary
        iRow = 4: r = iRow
        With sh.Rows(iRow + 1 & ":" & Rows.Count)
            .ClearContents: .Borders.Value = 0
        End With
        Set rRange = ws.Range("B5:B" & ws.Cells(Rows.Count, "B").End(xlUp).Row)
        Set rCell = rRange.Cells(1, 1)
        Do
            If rCell.Value = Chr(199) & Chr(225) & Chr(199) & Chr(204) & Chr(227) & Chr(199) & Chr(225) & Chr(237) Or rCell.Value = Empty Then GoTo NXT
            r = r + 1: t = 0
            sh.Cells(r, 1).Value = r - iRow
            sh.Cells(r, 2).Value = rCell.Value
            For c = 3 To 16
                Set rng = rCell.Offset(, c - 2).Resize(rCell.MergeArea.Rows.Count)
                t = Application.WorksheetFunction.Sum(rng)
                If t = 0 Then sh.Cells(r, c).Value = Empty Else sh.Cells(r, c).Value = t
            Next c
NXT:
            Set rCell = rCell.Offset(1, 0)
            Set rng = Nothing
        Loop Until (rCell.Row > (rRange.Row + rRange.Rows.Count - 1))
        With sh.Rows(iRow + 1 & ":" & r)
            .Borders.Value = 1
        End With
    Application.ScreenUpdating = True
End Sub

 

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

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

ما شاء الله بارك الله أخي الحبيب @lionheart حل رائع ، مذهل ، أحسنتم بارك الله بكم
تقبل تحياتي العطرة لشخصكم الكريم.

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

[محمد عبد الناصر]

ماشاء الله lionheart كود رائع بارك الله في علمك