Grup arası toplama

[mythc0d3]

Merhabalar işlem biraz karışık, anlatmaya çalışacağım. Elimde kendi oluşturduğum hata kodları arasında sayısı belli olmayan(Bunlar 1den 20ye kadar değişebilir..) veri grupları var. Yapmak istediğim B sütünündaki veri cinsine göre diğer verileri toplaması. Örneğin;
#Err 0 #Err 2 45T(A)+53T(B)
23.079 T(A)
21.984 T(A)
27.181 T(B)
26.135 T(B)
98.38 #Err 2
şeklinde bir veri aralığında istenen sonuç
=BİRLEŞTİR(YUVARLA(A2+A3;0.5);B2;"+";YUVARLA(A4+A5;0.5);B4)

Diğer bir örnek;

#Err 0 #Err 2 58T(A)+7T(B)+8T(C)+10T(Ç)
3.937 T(A)
4.307 T(A)
21.648 T(A)
23.635 T(A)
8.454 T(C)
9.589 T(Ç)
7.101 T(B)
4.583 T(A)
83.254 #Err 2

=BİRLEŞTİR(YUVARLA(A8+A9+A10+A11+A15;0.5);B8;"+";YUVARLA(A14;0.5);B14;"+";YUVARLA(A12;0.5);B12;"+";YUVARLA(A13;0.5);B13)

Veri yığının büyüklüğü genellikle 600 ila 1000 satır arasında oluyor daha kompleks durumlar için çok daha fazla. Bunu tek bir formülle yapmak pek mümkün görünmüyor. Bütün fikir ve tekliflere açığım. İlginize çok teşekkür ederim.

 

[mythc0d3]

Arkadaşlar herhangi fikri olan yok mu? Lütfen yardımlarınızı bekliyorum...

 

[Ömer]

Merhaba,

Module kopyalayıp çalıştırın.

Sub Hata_ToplaBirlestir()
 
    Dim i As Long, d As Object, sat As Long, x As Long
    Dim son As Long, deg As String, s, a1, j As Long, t As String
    
    son = Cells(Rows.Count, "A").End(xlUp).Row
    
    Application.ScreenUpdating = False
    Range("C:C").ClearContents
 
    For i = 1 To son
    
        If IsNumeric(Cells(i, "A")) = False Then
            Set d = CreateObject("Scripting.Dictionary")
            sat = i: x = i
        Else
            x = x + 1
        End If
            
        deg = Cells(x, "B")
        If IsNumeric(Cells(x, "A")) = True And _
            Left(Cells(x, "B"), 4) <> "#Err" Then
            If Not d.exists(deg) Then
                s = Array(Cells(x, "A"), Cells(x, "B"))
                d.Add deg, s
            Else
                s = d.Item(deg)
                s(0) = s(0) + Cells(x, "A")
                d.Item(deg) = s
            End If
        End If
 
        If IsNumeric(Cells(i + 1, "A")) = False Or i = son Then
            t = "": a1 = d.items
            For j = 0 To d.Count - 1
                s = a1(j)
                t = t & "+" & Round(s(0)) & s(1)
            Next j
            Cells(sat, "C") = Right(t, Len(t) - 1)
            Set d = Nothing
        End If
 
    Next i
 
    Application.ScreenUpdating = True
    
End Sub

.

 

[mythc0d3]

Nasıl teşekkür edeceğimi bilemiyorum. Çok teşekkür ederim. :redface:

 

[mythc0d3]

Hocam zahmet olmazsa algoritmayı da yazar mısınız?