مكتبة الموقع - جمع بشرط المتشابهات

[checles]

اعرض الملف

جمع بشرط المتشابهات

---

عايز مجموع العمود رقم 3 بس كل رقم خامه لوحده من العمود رقم 2

 

عايز مجموع العمود رقم 4 بس كل رخم خامه لوحده من العمود 2

و عايز عدد الصفف الي في عمود 1 بس من غير المتكرر

 

وشكرا

---

• صاحب الملف
  checles
• تمت الاضافه
  24 أبر, 2023
• الاقسام
  قسم الإكسيل

 

[lionheart]

Try this code

Sub Test()
    Dim rng As Range, iRow As Long, lr As Long, m As Long
    Application.ScreenUpdating = False
        With ActiveSheet
            .Columns("E:H").ClearContents
            lr = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            m = 3
            For iRow = 4 To lr
                If .Cells(iRow, "B").Value <> .Cells(iRow - 1, "B").Value Then
                    Set rng = .Range("A" & m & ":A" & iRow - 1)
                    .Cells(iRow - 1, "E").Value = .Cells(iRow - 1, "B").Value
                    .Cells(iRow - 1, "F").Value = CountUniqueValues(rng)
                    .Cells(iRow - 1, "G").Formula = "=SUM(" & rng.Offset(, 2).Address(0, 0) & ")"
                    .Cells(iRow - 1, "H").Formula = "=SUM(" & rng.Offset(, 3).Address(0, 0) & ")"
                    m = iRow
                End If
            Next iRow
        End With
    Application.ScreenUpdating = True
    MsgBox "Done", 64
End Sub

Function CountUniqueValues(ByVal rng As Range) As Long
    Dim cel As Range, dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    For Each cel In rng
        If Not dict.Exists(cel.Value) Then dict.Add cel.Value, 1
    Next cel
    CountUniqueValues = dict.Count
End Function

 

[checles]

شكرا جزيلا استاذ حسونه😃