Soru Satır Ekleyip Ortalama Vade Almak

[bulentkars]

Arkadaşlar Merhaba,

Ekteki çalışmada örnek olarak gösterdim, müşterilerin birden fazla vade ve tutarlarını alta satır ekleyip ortalama vadelerini almak istiyorum. yardımcı olabilirseniz sevinirim. Şimdiden Teşekkürler

 

[Ömer]

Merhaba,

Data sayfasında örnek olarak oluşturduğunuz 24.satır ve sonrasını silerek kodları çalıştırın.

Sub test()

    Dim son As Long, i As Long, s As Long
    
    son = Cells(Rows.Count, "A").End(xlUp).Row
    
    Application.ScreenUpdating = False
    
    Rows(son + 1).Delete
    If WorksheetFunction.CountA(Range("A3:A" & son)) + 2 <> son Then
        Range("A3:A" & son).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End If
    son = Cells(Rows.Count, "A").End(xlUp).Row
    
    Range("A3:H" & son).Sort Range("A2"), xlAscending
    
    s = 3: i = 2
    Do While Cells(s, "A") <> ""
        i = i + 1
        If Cells(i, "A") <> Cells(i + 1, "A") Then
            Rows(i + 1).Insert Shift:=xlDown
            Cells(i + 1, "C") = "ORT.TOPLAM"
            Cells(i + 1, "E") = Evaluate("=Sum(E" & s & ":E" & i & ")")
            Cells(i + 1, "D") = Evaluate("=SUMPRODUCT(D" & s & ":D" & i & "*E" & s & ":E" & i & ")") / Cells(i + 1, "E")
            Cells(i + 1, "E").NumberFormat = "#,##0.00"
            Cells(i + 1, "C").Resize(, 3).Font.Bold = True
            Cells(i + 1, "C").Resize(, 3).Interior.ColorIndex = 6
            s = i + 2
            i = i + 1
        End If
    Loop
    
    Application.ScreenUpdating = True
    
End Sub

 

[bulentkars]

Ömer Bey Merhaba,

Emeğinize sağlık. Tam istediğim olmuş. çok teşekkür ederim.