Benzersizlerin Ortalaması

[muratozmenler]

Merhabalar;

A​	B​	C​
Hasan	2023	90
Hasan	2023	80
Hasan	2024	50
Murat	2024	50
Murat	2023	100
Murat	2024	70

saydaki A,B ve C sütununda yer alan veriler aşağı doğru devam ediyor

D​	E​	F​
Hasan	2023 (iki tane var)	85 (toplamı 170 ortalaması 85)
Hasan	2024 (bir adet var)	50 (ortalaması aynı )
Murat	2023	100
Murat	2024	60

tablo2 de yer aldığı gibi yani A sütunundaki verileri B sütunundaki veriler ile teke indirip ortalamalarını vba kod ile almak istiyordum.


Teşekkürler.

 

[Tevfik_Kursun]

WorksheetFunction.Average(Range("Sayfa1!C1:C200")) işinizi görür sanırım, deneyiniz.
İyi çalışmalar

 

[muratozmenler]

Yanlış anlattım sanırsam kısaca özetlemek gerekirse A sütunundaki verileri D sütunundaki gibi teke indirecek B sütunundaki verileri E sütunundaki gibi teke indirecek ve F sütununa da D ve E sütunundaki kritere göre C sütunundaki değerler toplayım ortalamasını yazacak.
Formülle değil de makro ile vba ile v.b.. şekilde halletmek gerekiyor.

 

[Muhammet Okumuş]

Merhaba,
=ORTALAMA(EĞER(A$2:A$7=D2;EĞER(B$2:B$7=E2;C$2:C$7;"")))
Dizi formülüdür.

 

[muratozmenler]

Set S1 = Sheets("Rapor")
S1.Range("d2:f" & Rows.Count).Clear
son1 = S1.Cells(Rows.Count, "a").End(3).Row
son2 = S1.Cells(Rows.Count, "b").End(3).Row
ReDim ara1(son1): ReDim ara2(son1): ReDim ara3(son1):
For j = 2 To son1
ara1(j) = WorksheetFunction.Trim(S1.Cells(j, "a")) & WorksheetFunction.Trim(S1.Cells(j, "a"))
ara2(j) = 1
ara3(j) = WorksheetFunction.Trim(S1.Cells(j, "b")) & WorksheetFunction.Trim(S1.Cells(j, "b"))
Next j
sat1 = 2
For r = 2 To son1 And son2
aranan1 = ara1(r)
aranan2 = ara3(r)
sut3 = 0
If ara2(r) = 1 Then
For i = r To son1
If ara1(i) = aranan1 And ara3(i) = aranan2 Then
sut3 = sut3 + CDbl(S1.Cells(i, "c").Value)
ara2(i) = 0
End If
Next i
S1.Cells(sat1, 4).Value = S1.Cells(r, 1).Value
S1.Cells(sat1, 5).Value = S1.Cells(r, 2).Value
S1.Cells(sat1, 6).Value = sut3 ' burada toplamı veriyor ne yaptımsa burayı halledemedim

sat1 = sat1 + 1
End If
Next r


Bu kodu kullanıyorum fakat F sütununa C sütunun toplamını veriyor ortalamasını değil

 

[Muhammet Okumuş]

Sub Ortalama_Bul()
Application.ScreenUpdating = False
Range("D:G").ClearContents
son2 = Cells(Rows.Count, 1).End(3).Row
For i = 1 To son2
Cells(i, 6) = Cells(i, 1) & Cells(i, 2)
Next

For i = 1 To son2
If WorksheetFunction.CountIf(Range("F1:F" & i), Cells(i, 6)) = 1 Then
n = n + 1
Cells(n, 4) = Cells(i, 1)
Cells(n, 5) = Cells(i, 2)
End If
Next


son1 = Cells(Rows.Count, 4).End(3).Row

Range("F:F").ClearContents
For i = 1 To son1
krtr1 = Cells(i, 4)
krtr2 = Cells(i, 5)
n = 0
x = 0
For j = 1 To son2
If Cells(j, 1) = krtr1 And Cells(j, 2) = krtr2 Then
n = n + 1
x = Cells(j, 3) + x
End If
Next
If n > 0 Then
Cells(i, 6) = x / n
Cells(i, 7) = n & " tane var"
End If
Next

End Sub

Kodu deneyiniz.

 

[Korhan Ayhan]

Alternatif olsun..

Option Explicit

Sub My_Report()
    Dim S1 As Worksheet, S2 As Worksheet, Last_Row As Long, Avg_Formula As String
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
    
    Last_Row = S1.Cells(S1.Rows.Count, "A").End(3).Row
    Avg_Formula = "=AVERAGE(IF(" & S1.Name & "!A$2:A$1048576=D2,IF(" & S1.Name & "!B$2:B$1048576=E2," & S1.Name & "!C$2:C$1048576)))"
    Avg_Formula = Replace(Avg_Formula, 1048576, Last_Row)
    S2.Range("D:F").ClearContents
    S1.Columns("A:B").Copy S2.Range("D1")
    S2.Range("D:E").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    Last_Row = S2.Cells(S2.Rows.Count, "D").End(3).Row
    S2.Range("D1:F" & Last_Row).Sort S2.Range("D2"), xlAscending, S2.Range("E2"), , xlAscending, , , xlYes
    S2.Range("F1") = "C"
    S2.Range("F2").FormulaArray = Avg_Formula
    S2.Range("F2:F" & Last_Row).FillDown
    S2.Range("F2:F" & Last_Row).Value = S2.Range("F2:F" & Last_Row).Value
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[veyselemre]

Sub test()
    Dim sonA&, sonE&
    Range("E:G").ClearContents
    sonA = Cells(Rows.Count, 1).End(3).Row
    Range("A1:B" & sonA).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("E1"), Unique:=True
    sonE = Cells(Rows.Count, 5).End(3).Row
    Range("E1:F" & sonE).Sort Range("E1"), , Range("F1"), , , , , xlYes
    Range("G1").Value = "ORTALAMA"
    With Range("G2:G" & sonE)
        .Formula = "=AVERAGEIFS($C$2:$C$" & sonA & ",$A$2:$A$" & sonA & ",E2,$B$2:$B$" & sonA & ",F2)"
        .Value = .Value
    End With
End Sub

 

[muratozmenler]

Sub test()

Dim S1 As Worksheet, S2 As Worksheet, Last_Row As Long, Avg_Formula As String, Avg_Formula1 As String, Avg_Formula2 As String, Avg_Formula3 As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set S1 = Sheets("Rapor")
Set S2 = Sheets("Rapor")
Last_Row = S1.Cells(S1.Rows.Count, "A").End(3).Row
Avg_Formula = "=AVERAGE(IF(" & S1.Name & "!A$2:A$1048576=t2,IF(" & S1.Name & "!B$2:B$1048576=u2," & S1.Name & "!C$2:C$1048576)))"
Avg_Formula = Replace(Avg_Formula, 1048576, Last_Row)
Avg_Formula1 = "=AVERAGE(IF(" & S1.Name & "!A$2:A$1048576=t2,IF(" & S1.Name & "!B$2:B$1048576=u2," & S1.Name & "!e$2:e$1048576)))"
Avg_Formula1 = Replace(Avg_Formula1, 1048576, Last_Row)
Avg_Formula2 = "=sum(IF(" & S1.Name & "!A$2:A$1048576=t2,IF(" & S1.Name & "!B$2:B$1048576=u2," & S1.Name & "!f$2:f$1048576)))"
Avg_Formula2 = Replace(Avg_Formula2, 1048576, Last_Row)
Avg_Formula3 = "=sum(IF(" & S1.Name & "!A$2:A$1048576=t2,IF(" & S1.Name & "!B$2:B$1048576=u2," & S1.Name & "!d$2:d$1048576)))"
Avg_Formula3 = Replace(Avg_Formula3, 1048576, Last_Row)
S2.Range("t:y").ClearContents
S1.Columns("A:f").Copy S2.Range("t1")
S2.Range("t:y").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
Last_Row = S2.Cells(S2.Rows.Count, "t").End(3).Row
S2.Range("t1:y" & Last_Row).Sort S2.Range("t2"), xlAscending, S2.Range("u2"), , xlAscending, , , xlYes
S2.Range("v2").FormulaArray = Avg_Formula
S2.Range("v2:v" & Last_Row).FillDown
S2.Range("v2:v" & Last_Row).Value = S2.Range("v2:v" & Last_Row).Value
S2.Range("x2").FormulaArray = Avg_Formula1
S2.Range("x2:x" & Last_Row).FillDown
S2.Range("x2:x" & Last_Row).Value = S2.Range("x2:x" & Last_Row).Value
S2.Range("y2").FormulaArray = Avg_Formula2
S2.Range("y2:y" & Last_Row).FillDown
S2.Range("y2:y" & Last_Row).Value = S2.Range("y2:y" & Last_Row).Value
S2.Range("w2").FormulaArray = Avg_Formula3
S2.Range("w2:w" & Last_Row).FillDown
S2.Range("w2:w" & Last_Row).Value = S2.Range("w2:w" & Last_Row).Value
Set S1 = Nothing
Set S2 = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub


Çok teşekkürler vermiş olduğunuz cevapları kendime uyarlayarak sonuca ulaştım. Ortalamaları ve toplamları sorunsuz bir şekilde alıyor.