Sayın Haliliyas 
Öncelikle dönüş yapamadığım için sizden  özür diliyorum. kontrolleri yaptım. Uygulama şu haliyle fazlasıyla işimi görüyor. 
fakat iki sorun tespit ettim onları halletmeye çalışıyordum. 
1. Puantaj2 Hesapla butonuna iki defa bastığımda kayıtları tekrar ekliyor. önceki kayıtları silmeden yenilerini ekliyor. ben de hesaplama yapmadan önce hücreleri temizletip öyle deniyorum. sanırım o oldu
2. sorun ise her hesapla dediğimde 10 boş satır atıyor. bunlar dışında bir sorun yok. 
Hatta başta da dediğim gibi bu haliyle bile 10 numara oldu. işimi fazlasıyla görüyor. 
çok teşekkür ediyorum

bende boş satır eklemiyordu, şimdi denedim yine eklemedi. Siz kodda herhangi bir şey değiştirdiniz mi?

Hayır herhangi bir oynama yapmadım. indirdiğim dosyayı doğrudan kullandığımda da aynı sonuçla karşılaşıyorum. şimdi okuldaki bilgisayarımda da denedim. ekteki görüntüde de görüldüğü üzere 11, 12 ve 13. kayıtları tekrar kaydetmiş

2. olarak da az önce 10 defa bastım  her defasında ilk satırdan işlem yapmaya başladığı için eski verinin üstüne yazıyor dolayısıyla aynı veriyi 2 defa girmemesi gerekiyor.
kodda yer alan

• X0 = 3
  X1 = 3
  yPntj = 3
  

satırları verinin ekleneceği satırların başlama yerini gösteriyor.

modülün kodu aşağıdaki gibi mi kontrol eder misiniz?

Function vCevir2(Rng As String) As String

If Rng = 101 Then vCevir2 = "D"

If Rng = 103 Then vCevir2 = "F"

If Rng = 106 Then vCevir2 = "I"

If Rng = 107 Then vCevir2 = "K"

If Rng = 108 Then vCevir2 = "J"

If Rng = 109 Then vCevir2 = "L"

If Rng = 116 Then vCevir2 = "H"

If Rng = 117 Then vCevir2 = "G"

If Rng = 119 Then vCevir2 = "E"

End Function



Sub Puantaj2Hesap()

Dim EkASon, EkFSon, EkSonStn, X0, X1, yPntj, zSon As Long

On Error Resume Next

Tbas = Now

EkASon = Cells(Rows.Count, 1).End(xlUp).Row '

EkFSon = Cells(Rows.Count, 6).End(xlUp).Row

EkSonStn = Cells(3, Columns.Count).End(xlToLeft).Column





X0 = 3

X1 = 3

yPntj = 3

    Do While X1 <= EkFSon



        If yPntj > 12 Then '10 öğretmenden sonrası için

        Sheets("Puantaj2").Rows(yPntj).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove

        End If



        Sheets("Puantaj2").Range("A" & yPntj) = Range("A" & X0)

        Sheets("Puantaj2").Range("B" & yPntj) = Range("D" & X0)

        Sheets("Puantaj2").Range("C" & yPntj) = Range("E" & X0)

        X1 = Range("A" & X0).End(xlDown).Row

        If X1 > EkFSon Then X1 = EkFSon + 1

        For x = X0 To X1 - 1

            stn = vCevir2(Range("h" & x).Value)

            Sheets("Puantaj2").Range(stn & yPntj).Value = Cells(x, EkSonStn).Value

        Next

    yPntj = yPntj + 1

    X0 = X1



    Loop

'Formul___________________

zSon = Sheets("Puantaj2").Cells(Rows.Count, 13).End(xlUp).Row '13 ==> M sütunu

Sheets("Puantaj2").Range("M3") = "=sum(D3:L3)"

Sheets("Puantaj2").Range("M3:M" & zSon).FillDown

Sheets("Puantaj2").Range("D" & zSon) = "=sum(D3" & zSon - 1 & ")"

Sheets("Puantaj2").Range("D" & zSon & ":L" & zSon).FillRight

'___________________bitti

'Çerçeve__________________________

Range("A12:L" & zSon - 1).Borders.LineStyle = xlContinuous

'___________________Bitti



Tbit = Now

Sure = DateDiff("s", Tbas, Tbit) 'Tbit - Tbas

tSny = Sure Mod 60

tDk = Sure \ 60

MsgBox ("İşlem " & tDk & " dakika :" & tSny & " saniyede bitti") ' Tbit & " - " & Tbas)

End Sub

sizin eklediğiniz dosya üzerinde hiç oynama yapmadan sadece puantaj2 butonuna basarak ekran görüntüsü aldım. ilkinde 23. satıra kadar kayıt varken ikinci başışımda 35. satıra kadar kayıt ekledi. ekran görüntüleri ektedir.