• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Grup grup sıralama

Merhaba,
Ortalamaları yana yazacak şekilde düzenledim.

Sub Sırala()
Application.ScreenUpdating = False
Range("G:K") = ""
x = Cells(Rows.Count, 5).End(3).Row
For i = 1 To x

alt = Cells(Rows.Count, 7).End(3).Row + 1
If Cells(i, 5) = "MODEL" Then Cells(alt, 7) = i + 1


Next
alt = Cells(Rows.Count, 7).End(3).Row + 1
Cells(alt, 7) = Cells(Rows.Count, 5).End(3).Row


x = Cells(Rows.Count, 7).End(3).Row - 1
For i = 2 To x
a = Cells(i, 7)
b = Cells(i + 1, 7) - 2
Range(Cells(a, 2), Cells(b, 5)).Sort Range("E" & a)
Next

x = Cells(Rows.Count, 7).End(3).Row - 1
Range("I2:J" & x) = "=OFFSET(D$1,$G2-2,0)"
Range("K2:K" & x) = "=AVERAGE(INDIRECT(""D""&G2&"":D""&G3-2))"

Range("I2:K" & x) = Range("I2:K" & x).Value

Range("G:G") = ""
son = Cells(Rows.Count, 5).End(3).Row
Range("F1") = "MODEL"
Range("F2:F" & son) = "=IF(E2=""MODEL"",""MODEL"",MAX(F1:F1)+1)"
Range("E2:E" & son) = Range("F2:F" & son).Value

Range("F:F") = ""
End Sub
 
Son düzenleme:
Düşey profili çıkarmak için bu kadarı kesinlikle yeterli üstad.Emeğine sağlık.Allah razı olsun.
 
Merhaba,
Kodun son bölümündeki ortalamada sorun varmış.

Sub Sırala()
Application.ScreenUpdating = False
Range("G:G") = ""
x = Cells(Rows.Count, 5).End(3).Row
For i = 1 To x

alt = Cells(Rows.Count, 7).End(3).Row + 1
If Cells(i, 5) = "MODEL" Then Cells(alt, 7) = i + 1


Next
alt = Cells(Rows.Count, 7).End(3).Row + 1
Cells(alt, 7) = Cells(Rows.Count, 5).End(3).Row + 2


x = Cells(Rows.Count, 7).End(3).Row - 1
For i = 2 To x
a = Cells(i, 7)
b = Cells(i + 1, 7) - 2
Range(Cells(a, 2), Cells(b, 5)).Sort Range("E" & a)
Next

x = Cells(Rows.Count, 7).End(3).Row - 1
Range("I2:J" & x) = "=OFFSET(D$1,$G2-2,0)"
Range("K2:K" & x) = "=AVERAGE(INDIRECT(""D""&G2&"":D""&G3-2))"
Range("I2:K" & x) = Range("I2:K" & x).Value
Range("G:G") = ""
son = Cells(Rows.Count, 5).End(3).Row
Range("F1") = "MODEL"
Range("F2:F" & son) = "=IF(E2=""MODEL"",""MODEL"",MAX(F1:F1)+1)"
Range("E2:E" & son) = Range("F2:F" & son).Value

Range("F:F") = ""
End Sub

Bu kodu kullanınız.
 
Geri
Üst