Tekrar sayısına göre Ortalama almak

[hadromer]

Merhaba,
örnek dosyada görüldüğü gibi A sütununda S01-S44 arası değişkenlerim var. Diğer sütunlar ise numaralı başlıklardan oluşuyor.
A sütununda Bazı değişkenler 3 kere tekrar ederken bazıları 1 veya 2 kere tekrar ediyor.
Ben Asütunundaki değişkenlerin tekrar sayılarına göre diğer sütunlarda yer alan verilerin ortalamasını almak istiyorum.
Virgüllü sayılar olursa bunlar yukarı yuvarlanacak. Yani tam sayı olmalı.
Ortalama sonucunda yeni bir sayfada S01-S02-S03....-S44 olmak üzere toplam 44 veri yer alacak.
=Eğerortalama formülünü denedim ancak istediğim gibi olmadı. Tek tek hücre numarası düzeltmem gerekiyor.
Yardımcı olabilir misiniz ? Teşekkür ederim

 

[Korhan Ayhan]

B2 hücresine uygulayınız.

DİZİ formüldür.

İhtiyacınız kadar alta ve sağa doğru sürükleyiniz.

=EĞERHATA(ORTALAMA(EĞER(SOLDAN(Sayfa1!$A$2:$A$119;UZUNLUK($A2))=$A2;EĞER(KIRP(Sayfa1!B$2:B$119)<>"";EĞER(Sayfa1!B$2:B$119<>0;EĞERHATA(YUVARLA(Sayfa1!B$2:B$119;0);0)))));"")

 

[hadromer]

B2 hücresine uygulayınız.

DİZİ formüldür.

İhtiyacınız kadar alta ve sağa doğru sürükleyiniz.

=EĞERHATA(ORTALAMA(EĞER(SOLDAN(Sayfa1!$A$2:$A$119;UZUNLUK($A2))=$A2;EĞER(KIRP(Sayfa1!B$2:B$119)<>"";EĞER(Sayfa1!B$2:B$119<>0;EĞERHATA(YUVARLA(Sayfa1!B$2:B$119;0);0)))));"")

Çok teşekkür ederim. İstediğim gibi çalışıyor.

 

[veyselemre]

Sub vEmre()
    '14122022
    Application.ScreenUpdating = False
    Dim veri, liste, w(1 To 2, 2 To 142), i&, ii%, ky$, y
    
    With Sheets("Rapor")
        With .Range("B2:EL" & .Cells(Rows.Count, "A").End(3).Row)
            .ClearContents
        End With
        With .Range("A2:EL" & .Cells(Rows.Count, "A").End(3).Row)
            liste = .Value
        End With
    End With

    
    With Sheets("Rapor")
        liste = .Range("A2:EL" & .Cells(Rows.Count, "A").End(3).Row).Value
    End With
    
    With Sheets("Sayfa1")
        veri = .Range("A2:EL" & .Cells(Rows.Count, "A").End(3).Row).Value
    End With
    
    With CreateObject("Scripting.Dictionary")
    
        For i = LBound(liste) To UBound(liste)
            ky = liste(i, 1)
            .Item(ky) = w
        Next i
        
        For i = LBound(veri) To UBound(veri)
            ky = Left(veri(i, 1), 3)
            If .exists(ky) Then
                y = .Item(ky)
                For ii = 2 To 142
                    If Val(veri(i, ii)) > 0 Then
                        y(1, ii) = y(1, ii) + veri(i, ii)
                        y(2, ii) = y(2, ii) + 1
                        .Item(ky) = y
                    End If
                Next ii
            Else
                MsgBox ky & vbCr & "Rapor sayfasında bulunamamıştır.", vbCritical
                Exit Sub
            End If
        Next i

        For i = LBound(liste) To UBound(liste)
            ky = liste(i, 1)
            If .exists(ky) Then
                y = .Item(ky)
                For ii = 2 To 142
                    If Val(y(1, ii)) > 0 Then
                        liste(i, ii) = WorksheetFunction.RoundUp(y(1, ii) / y(2, ii), 0)
                    End If
                Next ii
            End If
        Next i
    
    End With
    
    With Sheets("Rapor")
        With .Range("A2:EL" & .Cells(Rows.Count, "A").End(3).Row)
            .Value = liste
        End With
    End With
    
    Application.ScreenUpdating = True
    
End Sub

 

[veyselemre]

Formül işlerinden anlamam ama Korhan Bey tek satırda işi çözünce, bir de ben uğraşayım dedim tesadüfi sonuç doğru galiba.

=IFERROR(ROUNDUP(SUMIFS(Sayfa1!B$2:B$119;Sayfa1!$A$2:$A$119;$A2 & "?")/COUNTIFS(Sayfa1!$A$2:$A$119;$A2 & "?";Sayfa1!B$2:B$119;">0");0);"")

 

[hadromer]

Sub vEmre()
    '14122022
    Application.ScreenUpdating = False
    Dim veri, liste, w(1 To 2, 2 To 142), i&, ii%, ky$, y
   
    With Sheets("Rapor")
        With .Range("B2:EL" & .Cells(Rows.Count, "A").End(3).Row)
            .ClearContents
        End With
        With .Range("A2:EL" & .Cells(Rows.Count, "A").End(3).Row)
            liste = .Value
        End With
    End With

   
    With Sheets("Rapor")
        liste = .Range("A2:EL" & .Cells(Rows.Count, "A").End(3).Row).Value
    End With
   
    With Sheets("Sayfa1")
        veri = .Range("A2:EL" & .Cells(Rows.Count, "A").End(3).Row).Value
    End With
   
    With CreateObject("Scripting.Dictionary")
   
        For i = LBound(liste) To UBound(liste)
            ky = liste(i, 1)
            .Item(ky) = w
        Next i
       
        For i = LBound(veri) To UBound(veri)
            ky = Left(veri(i, 1), 3)
            If .exists(ky) Then
                y = .Item(ky)
                For ii = 2 To 142
                    If Val(veri(i, ii)) > 0 Then
                        y(1, ii) = y(1, ii) + veri(i, ii)
                        y(2, ii) = y(2, ii) + 1
                        .Item(ky) = y
                    End If
                Next ii
            Else
                MsgBox ky & vbCr & "Rapor sayfasında bulunamamıştır.", vbCritical
                Exit Sub
            End If
        Next i

        For i = LBound(liste) To UBound(liste)
            ky = liste(i, 1)
            If .exists(ky) Then
                y = .Item(ky)
                For ii = 2 To 142
                    If Val(y(1, ii)) > 0 Then
                        liste(i, ii) = WorksheetFunction.RoundUp(y(1, ii) / y(2, ii), 0)
                    End If
                Next ii
            End If
        Next i
   
    End With
   
    With Sheets("Rapor")
        With .Range("A2:EL" & .Cells(Rows.Count, "A").End(3).Row)
            .Value = liste
        End With
    End With
   
    Application.ScreenUpdating = True
   
End Sub

Kod ve formül için çok teşekkür ederim. Bu da çok pratik oldu. elinize sağlık