(01/06/2021, 18:31)feraz yazdı: With Range("L3:L1" & satr + 2)

Bordaki 1 silinmesi gerek abey..Alttaki gibi olacak dikkatten kaçmış.

Çok teşekkürler Hocam ellerinize sağlık.

Rica ederim abey.
Dahada hızlı çalışsın isterseniz alttaki kodu kullanabilirsiniz.

    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
Yukaraki kodları sevmediğim için başta kullanmamıştım yinede yazayım dedim.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim i As Long

    Const satr As Byte = 16 'K sütunundaki verilerin son satir numarasi arananinkilerin

    Const SatirBaslangic As Byte = 2 '3.cü sütundan baslandigi icin 2 yazildi

    Dim sonDoluSatrEtopla As Long

    

    sonDoluSatrEtopla = Cells.Find("*", , , , , xlPrevious).Row + 1



    If Intersect(Target, Union(Range("A3" & Rows.Count), Range("F3:i" & Rows.Count))) Is Nothing Then Exit Sub

    Application.Calculation = xlCalculationManual

    Application.EnableEvents = False

    ActiveSheet.Unprotect "123321"

    Range("L3:N" & Rows.Count).ClearContents

    On Error GoTo son

    With Range("L3:L" & satr + SatirBaslangic)

        .Formula = "=SUMIF($A$3:$A$" & sonDoluSatrEtopla & ",K3,$D$3:$D$" & sonDoluSatrEtopla & ")"

        .Value = .Value

    End With



    With Range("M3:M" & satr + SatirBaslangic)

        .Formula = "=SUMIF($F$3:$F$" & sonDoluSatrEtopla & ",K3,$I$3:$I$" & sonDoluSatrEtopla & ")"

        .Value = .Value

    End With 'Etopla sonu



    ReDim arr(1 To satr, 1 To 1)

    For i = 1 To satr

        arr(i, 1) = Cells(i + SatirBaslangic, "L").Value - Cells(i + SatirBaslangic, "M").Value

    Next

    Range("N3:N" & satr + SatirBaslangic).Value = arr

    

    Range("L20").Value = WorksheetFunction.Sum(Range("D3" & sonDoluSatrEtopla))

    Range("L21").Value = WorksheetFunction.Sum(Range("I3:I" & sonDoluSatrEtopla))

    Range("L22").Value = Range("L20").Value - Range("L21").Value

    

    Erase arr

    ActiveSheet.Protect "123321"

    Application.EnableEvents = True

    Application.Calculation = xlCalculationAutomatic

    Exit Sub

son:

    Application.EnableEvents = True

    Application.Calculation = xlCalculationAutomatic

    MsgBox "hata", vbCritical

End Sub

Birde Evaluate yötemii kulladım.Bununla formülleri değer yapmaktansa direk değer yapıyor.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim i As Long, satirbasveFazlasi As Long

    Const satr As Byte = 16 'K sütunundaki verilerin son satir numarasi arananinkilerin

    Const SatirBaslangic As Byte = 2 '3.cü sütundan baslandigi icin 2 yazildi

    Dim sonDoluSatrEtopla As Long

    

    sonDoluSatrEtopla = Cells.Find("*", , , , , xlPrevious).Row + 1



    If Intersect(Target, Union(Range("A3" & Rows.Count), Range("F3:i" & Rows.Count))) Is Nothing Then Exit Sub

    

    Application.Calculation = xlCalculationManual

    Application.EnableEvents = False

    Application.ScreenUpdating = False

    

    ActiveSheet.Unprotect "123321"

    Range("L3:N" & Rows.Count).ClearContents

    On Error GoTo son

    

    satirbasveFazlasi = satr + SatirBaslangic



    Range("L3:L" & satirbasveFazlasi).Value = Evaluate("=SUMIF($A$3:$A$" & sonDoluSatrEtopla & ",K3:K" & satirbasveFazlasi & ",$D$3:$D$" & sonDoluSatrEtopla & ")")

    Range("M3:M" & satirbasveFazlasi).Value = Evaluate("=SUMIF($F$3:$F$" & sonDoluSatrEtopla & ",K3:K" & satirbasveFazlasi & ",$I$3:$I$" & sonDoluSatrEtopla & ")")



    ReDim arr(1 To satr, 1 To 1)

    For i = 1 To satr

        arr(i, 1) = Cells(i + SatirBaslangic, "L").Value - Cells(i + SatirBaslangic, "M").Value

    Next

    Range("N3:N" & satirbasveFazlasi).Value = arr

    

    Range("L20").Value = WorksheetFunction.Sum(Range("D3" & sonDoluSatrEtopla))

    Range("L21").Value = WorksheetFunction.Sum(Range("I3:I" & sonDoluSatrEtopla))

    Range("L22").Value = Range("L20").Value - Range("L21").Value

    

    Erase arr

    ActiveSheet.Protect "123321"

    

    Application.EnableEvents = True

    Application.Calculation = xlCalculationAutomatic

    Application.ScreenUpdating = True

    

    Exit Sub

son:



    Application.EnableEvents = True

    Application.Calculation = xlCalculationAutomatic

    Application.ScreenUpdating = True

    

    MsgBox "hata", vbCritical

End Sub

Çok teşekkürler Hocam ellerine sağlık. Eklediğin dosyayı indirdim. inceleyip dönüş yapacam.

Hocam Mesaj 16 daki kodlar daha hızlı çalışıyor. Ancak L ve M hücrelerinde Etoplamları göstermiyor. Mesaj 15 deki kodlar L ve M hücrelerinde Etoplamları gösteriyor. Mesaj 16 daki kodlar daha hızlı çalışıyor. 16 daki kodlar L ve M hücrelerinde Etoplamları göstermediği için mi daha hızlı çalışıyor. Eğer Mesaj 16 daki kotlar Etoplamları gösterdiği zamanda yine öyle hızlı çalışırsa çok iyi.