Makro ile dolu hücrelerin ortalamasın alma.

[Bora K]

Merhabalar

c2:c12 aralığındaki dolu hücrelerin ortalamasın d1
d2:d12 aralığındaki dolu hücrelerin ortalamasın e1
e2:e12 aralığındaki dolu hücrelerin ortalamasın f1
................................................................
hücresinde görecek şekilde bir kod istemekteyim.
Yardımınızı bekliyorum lütfen.

 

[apocalyt]

şunu deneyin..

Sub dayight()
On Error Resume Next
For x = 3 To Cells(2, 200).End(xlToLeft).Column
a = WorksheetFunction.Average(Range(Cells(2, x), Cells(12, x)))
Cells(1, x + 1) = a
a = 0
Next x
End Sub

 

[Bora K]

Merhabalar
apocalyt üstad.

Kod gayet güzel çalışıyor. Biraz değiştirip
başka şekilde kullanmak istedim ama başaramadım.
ekdeki dosyaya bakabilirsiniz acaba?

 

[YUSUF44]

Şu formül işinizi görmüyor mu?

=EĞERORTALAMA(C8:D16;">0";C8:D16)

 

[Bora K]

Alakanız için teşekkür ederim.
Makro ile olsun istiyorum mümkünse

 

[YUSUF44]

Şu kodları ilgili sayfanın kod bölümüne yapıştırıp dener misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("c8:d16")) Is Nothing Then GoTo 10
[f3] = WorksheetFunction.AverageIf(Range("c8:d16"), ">0", Range("c8:d16"))
10:
If Intersect(Target, Range("I8:J16")) Is Nothing Then Exit Sub
[h3] = WorksheetFunction.AverageIf(Range("I8:J16"), ">0", Range("I8:J16"))
End Sub

 

[Bora K]

Yusuf Bey aşağıdaki satırlarda hata veriyor.

[h3] = WorksheetFunction.AverageIf(Range("I8:J16"), ">0", Range("I8:J16"))
[f3] = WorksheetFunction.AverageIf(Range("c8:d16"), ">0", Range("c8:d16"))

 

[omerceri]

Aşağıdaki makro sayfanın neresinde olursa olsun fontları kırmızı veya mavi renge ayarlanmış boş veya metin olmayan hücre değerlerinin ortalamasını alıyor. h3 ve f3 hücrelerine yazıyor.

Sub Makro3()
 Range("A1").Select
Application.FindFormat.Font.ColorIndex = 3
son = Cells.Find(What:="", After:=Range("A1"), LookIn:=xlFormulas, SearchFormat:=True, SearchDirection:=xlPrevious).Address
    Do
    Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, SearchFormat:=True).Activate

If ActiveCell <> "" And IsNumeric(ActiveCell) Then
         Top = Top + ActiveCell
         say = say + 1
         End If
Loop While ActiveCell.Address <> son
 Range("F3").Value = Top / say
 Range("A1").Select
 Application.FindFormat.Font.ColorIndex = 5
son = Cells.Find(What:="", After:=Range("A1"), LookIn:=xlFormulas, SearchFormat:=True, SearchDirection:=xlPrevious).Address
    Do
    Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, SearchFormat:=True).Activate
 
If ActiveCell <> "" And IsNumeric(ActiveCell) Then
         top1 = top1 + ActiveCell
         say1 = say1 + 1
         End If
       
Loop While ActiveCell.Address <> son
 Range("H3").Value = top1 / say1
End Sub

 

[Korhan Ayhan]

Yusuf beyin önerdiği formül ve kodlar 2007 ve üzeri versiyonlarda sonuç vermektedir. Alternatif olarak aşağıdaki kodu kullanabilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, Range("C8:D1000", "I8:J1000")) Is Nothing Then Exit Sub
    Range("F3") = Evaluate("=AVERAGE(IF(C8:D1000<>0,C8:D1000))")
    Range("H3") = Evaluate("=AVERAGE(IF(I8:J1000<>0,I8:J1000))")
End Sub

 

[YUSUF44]

Yusuf beyin önerdiği formül ve kodlar 2007 ve üzeri versiyonlarda sonuç vermektedir. Alternatif olarak aşağıdaki kodu kullanabilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, Range("C8:D1000", "I8:J1000")) Is Nothing Then Exit Sub
    Range("F3") = Evaluate("=AVERAGE(IF(C8:D1000<>0,C8:D1000))")
    Range("H3") = Evaluate("=AVERAGE(IF(I8:J1000<>0,I8:J1000))")
End Sub

Ben de yeni bir şey öğrenmiş oldum, teşekkürler.

 

[Bora K]

Değerli üstadlar;
güzel paylaşımlarınız için
çok teşekkür ederim.
Esen kalınız.