AccessTr.neT

aşağıdaki kod ilk sayfadaki toplamlar sütunundan değerleri alıp puantaj2 sayfasına yapıştırıyor, işlem yükü azaldığı için daha hızlı.
Ama yeni öğretmenler eklenmesine rağmen toplam sütunundaki formül boş bırakılmışsa boş değer dönderir

Sub Puantaj2()

Dim xSatirNo, ASonSatir, FSonSatir, XAlanlar, xSiraNo, xSonSutun As Long

xSonSutun = Cells(3, Columns.Count).End(xlToLeft).Column ' - 1

SonHrf = Replace(Cells(1, xSonSutun).Address(0, 0), 1, "")

xSatirNo = 3

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

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



XAlanlar = 3

Do While 1 = 1



    xSatirNo = Range("A" & xSatirNo).End(xlDown).Row

    y = Range("a" & XAlanlar).Value

    x = XAlanlar

    Sheets("Puantaj2").Range("B" & 2 + y).Value = Range("D" & x).Value

    Sheets("Puantaj2").Range("C" & 2 + y).Value = Range("E" & x).Value

    If xSatirNo > ASonSatir Then Exit Do

    For x = XAlanlar To xSatirNo - 1

        y = Range("a" & XAlanlar).Value

      '  MsgBox ("R" & x & ":" & SonHrf & x)

        If Range("h" & x).Value = 101 Then Sheets("Puantaj2").Range("D" & 2 + y).Value = Range(SonHrf & x).Value

        If Range("h" & x).Value = 103 Then Sheets("Puantaj2").Range("f" & 2 + y).Value = Range(SonHrf & x).Value

        If Range("h" & x).Value = 106 Then Sheets("Puantaj2").Range("I" & 2 + y).Value = Range(SonHrf & x).Value

        If Range("h" & x).Value = 107 Then Sheets("Puantaj2").Range("K" & 2 + y).Value = Range(SonHrf & x).Value

        If Range("h" & x).Value = 108 Then Sheets("Puantaj2").Range("J" & 2 + y).Value = Range(SonHrf & x).Value

        If Range("h" & x).Value = 109 Then Sheets("Puantaj2").Range("L" & 2 + y).Value = Range(SonHrf & x).Value

        If Range("h" & x).Value = 116 Then Sheets("Puantaj2").Range("H" & 2 + y).Value = Range(SonHrf & x).Value

        If Range("h" & x).Value = 117 Then Sheets("Puantaj2").Range("G" & 2 + y).Value = Range(SonHrf & x).Value

        If Range("h" & x).Value = 119 Then Sheets("Puantaj2").Range("E" & 2 + y).Value = Range(SonHrf & x).Value





    Next

     XAlanlar = xSatirNo

Loop

    Sheets("Puantaj2").Range("B" & 2 + y).Value = Range("D" & x).Value

    Sheets("Puantaj2").Range("C" & 2 + y).Value = Range("E" & x).Value

    For x = XAlanlar To FSonSatir

        y = Range("a" & XAlanlar).Value

        If Range("h" & x).Value = 101 Then Sheets("Puantaj2").Range("D" & 2 + y).Value = Range(SonHrf & x).Value

        If Range("h" & x).Value = 103 Then Sheets("Puantaj2").Range("f" & 2 + y).Value = Range(SonHrf & x).Value

        If Range("h" & x).Value = 106 Then Sheets("Puantaj2").Range("I" & 2 + y).Value = Range(SonHrf & x).Value

        If Range("h" & x).Value = 107 Then Sheets("Puantaj2").Range("K" & 2 + y).Value = Range(SonHrf & x).Value

        If Range("h" & x).Value = 108 Then Sheets("Puantaj2").Range("J" & 2 + y).Value = Range(SonHrf & x).Value

        If Range("h" & x).Value = 109 Then Sheets("Puantaj2").Range("L" & 2 + y).Value = Range(SonHrf & x).Value

        If Range("h" & x).Value = 116 Then Sheets("Puantaj2").Range("H" & 2 + y).Value = Range(SonHrf & x).Value

        If Range("h" & x).Value = 117 Then Sheets("Puantaj2").Range("G" & 2 + y).Value = Range(SonHrf & x).Value

        If Range("h" & x).Value = 119 Then Sheets("Puantaj2").Range("E" & 2 + y).Value = Range(SonHrf & x).Value

    Next

MsgBox ("Son Sütun: " & SonHrf)

End Sub

2. yöntemde ise her toplama işlemini kendi yaptığı için daha ağır ama sonuç daha güvenilir

Sub Puantaj2()

Dim xSatirNo, ASonSatir, FSonSatir, XAlanlar, xSiraNo, xSonSutun As Long

xSonSutun = Cells(3, Columns.Count).End(xlToLeft).Column - 1

SonHrf = Replace(Cells(1, xSonSutun).Address(0, 0), 1, "")

xSatirNo = 3

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

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



XAlanlar = 3

Do While 1 = 1



    xSatirNo = Range("A" & xSatirNo).End(xlDown).Row

    y = Range("a" & XAlanlar).Value

    x = XAlanlar

    Sheets("Puantaj2").Range("B" & 2 + y).Value = Range("D" & x).Value

    Sheets("Puantaj2").Range("C" & 2 + y).Value = Range("E" & x).Value

    If xSatirNo > ASonSatir Then Exit Do

    For x = XAlanlar To xSatirNo - 1

        y = Range("a" & XAlanlar).Value

        If Range("h" & x).Value = 101 Then Sheets("Puantaj2").Range("D" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))  

        If Range("h" & x).Value = 103 Then Sheets("Puantaj2").Range("f" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))  

        If Range("h" & x).Value = 106 Then Sheets("Puantaj2").Range("I" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))   

        If Range("h" & x).Value = 107 Then Sheets("Puantaj2").Range("K" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))  

        If Range("h" & x).Value = 108 Then Sheets("Puantaj2").Range("J" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))   

        If Range("h" & x).Value = 109 Then Sheets("Puantaj2").Range("L" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))  

        If Range("h" & x).Value = 116 Then Sheets("Puantaj2").Range("H" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))   

        If Range("h" & x).Value = 117 Then Sheets("Puantaj2").Range("G" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))   

        If Range("h" & x).Value = 119 Then Sheets("Puantaj2").Range("E" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))  





    Next

     XAlanlar = xSatirNo

Loop

    Sheets("Puantaj2").Range("B" & 2 + y).Value = Range("D" & x).Value

    Sheets("Puantaj2").Range("C" & 2 + y).Value = Range("E" & x).Value

    For x = XAlanlar To FSonSatir

        y = Range("a" & XAlanlar).Value

        If Range("h" & x).Value = 101 Then Sheets("Puantaj2").Range("D" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))  

        If Range("h" & x).Value = 103 Then Sheets("Puantaj2").Range("f" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))   

        If Range("h" & x).Value = 106 Then Sheets("Puantaj2").Range("I" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))  

        If Range("h" & x).Value = 107 Then Sheets("Puantaj2").Range("K" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))  

        If Range("h" & x).Value = 108 Then Sheets("Puantaj2").Range("J" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))  

        If Range("h" & x).Value = 109 Then Sheets("Puantaj2").Range("L" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))  

        If Range("h" & x).Value = 116 Then Sheets("Puantaj2").Range("H" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))   

        If Range("h" & x).Value = 117 Then Sheets("Puantaj2").Range("G" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))   

        If Range("h" & x).Value = 119 Then Sheets("Puantaj2").Range("E" & 2 + y).Value = Application.WorksheetFunction.Sum(Range("R" & x & ":" & SonHrf & x))   

    Next

MsgBox ("Son Sütun: " & SonHrf)

End Sub

5. mesajdaki dosya güncellenmiştir.
iyi çalışmalar

10 dan fazla öğretmen için kodu düzeltmeye çalışıyorum

Sayın Haliliyas
Sizi de yordum kusur kalmayın. 
Hakkınızı helal edin lütfen

baya denedim, hata yok gibi ama gözümden kaçan şeyler olabilir.
bir de bence yapabiliyorsanız Sayfa1(Ekders) sayfasına isim yada ders programı eklendikçe toplam hesaplama sütunu otomatik olarak aşağı doğru yayılmalı. yoksa her defasında elle girmeniz/ aşağı doğru kopyala yapmanız gerekiyor.
eğer unutursanız hata verir uygulama.
Düzeltme: ben kopyala/yapıştırla yaptığımdan olmamış ama her satır eklendiğinde hesaplama işlemi otomatik olarak yapılıyormuş.
iyi çalışmalar,
Dilerim işinize yarar.

son durumla ilgili bilgi verir misiniz?