Çözüldü Geçmiş kayıtları oluşturma

Korhan Ayhan · 23 Ekim 2022

Deneyiniz.

C++:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sh As Worksheet
    
    If Intersect(Target, Range("D7:D30")) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    
    If Target <> "" Then
        Set Sh = Sheets("Arşiv")
        If WorksheetFunction.CountIfs(Sh.Range("A:A"), Cells(Target.Row, "A"), _
                                      Sh.Range("B:B"), Cells(Target.Row, "B"), _
                                      Sh.Range("C:C"), Cells(Target.Row, "C"), _
                                      Sh.Range("D:D"), Cells(Target.Row, "D"), _
                                      Sh.Range("E:E"), Cells(Target.Row, "E"), _
                                      Sh.Range("F:F"), Cells(Target.Row, "F"), _
                                      Sh.Range("G:G"), Cells(Target.Row, "G"), _
                                      Sh.Range("H:H"), Cells(Target.Row, "H"), _
                                      Sh.Range("I:I"), Cells(Target.Row, "I"), _
                                      Sh.Range("J:J"), Cells(Target.Row, "J"), _
                                      Sh.Range("K:K"), Cells(Target.Row, "K"), _
                                      Sh.Range("L:L"), Cells(Target.Row, "L"), _
                                      Sh.Range("M:M"), Cells(Target.Row, "M"), _
                                      Sh.Range("N:N"), Cells(Target.Row, "N"), _
                                      Sh.Range("O:O"), Cells(Target.Row, "O")) = 0 Then
            Application.ScreenUpdating = False
            Range("A" & Target.Row & ":Q" & Target.Row).Copy
            Sh.Cells(1048576, "A").End(3)(2, 1).PasteSpecial xlPasteValues
            Sh.Cells(1048576, "A").End(3)(1, 1).PasteSpecial xlPasteFormats
            Sh.Cells(1048576, "P").End(3)(2, 1) = Now
            With Sh.Range("O2:O" & Sh.Cells(1048576, "A").End(3).Row)
                .Formula = "=IF(A1<>A2,"""",(0.0416666666642413*(L2-L1))/(D2-D1))"
                .Value = .Value
            End With
            Application.CutCopyMode = False
            Application.ScreenUpdating = True
        Else
            MsgBox "Bu kayıt daha önce arşiv sayfasına aktarılmıştır.", vbCritical
        End If
        Set Sh = Nothing
    End If
End Sub

Ömer Çakır · 24 Ekim 2022

Korhan Bey, teşekkür ederim. Güzel olmuş.
Son olarak, hesapladığı değeri tam sayı olarak yazdırabilir mi acaba ondalıklarla karışık görünüyor çünkü.

Birde son olarak Arşiv adlı sayfada kullanıcı filte dışında birşey değiştiremesin. Kayıtlarla oynayamasın. Ben Arşiv sayfası için sayfa koruma denedim ama bu sefer makro hata verdi.

Arşiv sayfasını varsayılan şifre abc olacak şekilde korumaya alabilir miyiz acaba. Tabi son olarak BALLAST CALCULATION sayfasınıda korumaya alacağım, kullanıcı sadece BALLAST CALCULATION da turuncu yerlere değer girebilecek. Kullanıcı bilerek/bilmeyerek Arşive ve makroya müdehale edemez olursa daha emniyetli olacaktır. Bu programı benimle beraber kullanan diğer arkadaşların zarar vermesinden korumak için.

Korhan Ayhan · 24 Ekim 2022

Tamsayı için sütunu sayısal olarak biçimlendirseniz işinizi görmez mi? Sütunu seçip hücre biçimlendirme menüsünü kullanarak ondalikları kaldırabilirsiniz. Yok tamamen hiç ondalık olmasın diyorsanız elbette bu özellik makroya eklenebilir.

Koruma için müsait olduğumda koda ekleme yaparım.

Ömer Çakır · 25 Ekim 2022

Korhan Ayhan' Alıntı:
Tamsayı için sütunu sayısal olarak biçimlendirseniz işinizi görmez mi? Sütunu seçip hücre biçimlendirme menüsünü kullanarak ondalikları kaldırabilirsiniz. Yok tamamen hiç ondalık olmasın diyorsanız elbette bu özellik makroya eklenebilir.

Koruma için müsait olduğumda koda ekleme yaparım.

Korhan Bey, günaydın.

Sütunu sayısal olarak tam sayı şeklinde biçimlendirdim ama yeni değerler girildiğinde yine ondalıklar çıkıyor.

Ömer Çakır · 30 Ekim 2022

Korhan Bey, iyi günler,

Aşağıdaki kodlarla

1. Arşiv sayfası için sayfa korumasını etkinleştirdim, ama D, E, F, G, H ve Q sütunlarındaki hücreleri kilitlemiyor, diğerlerini kilitliyor.
2. Arşiv sayfası O sütunu ondalıkları kaldıramadım, önerdiğiniz hücre biçim ayarlarını denedim ama yeni hesapladığı değerleri ondalıklı yazıyor hep, sizden ricam O sütununu ondalıksız yazabilirse iyi olur.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sh As Worksheet
    
    If Intersect(Target, Range("D7:D30")) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    
    If Target <> "" Then
        Set Sh = Sheets("Arşiv")
        If WorksheetFunction.CountIfs(Sh.Range("A:A"), Cells(Target.Row, "A"), _
                                      Sh.Range("B:B"), Cells(Target.Row, "B"), _
                                      Sh.Range("C:C"), Cells(Target.Row, "C"), _
                                      Sh.Range("D:D"), Cells(Target.Row, "D"), _
                                      Sh.Range("E:E"), Cells(Target.Row, "E"), _
                                      Sh.Range("F:F"), Cells(Target.Row, "F"), _
                                      Sh.Range("G:G"), Cells(Target.Row, "G"), _
                                      Sh.Range("H:H"), Cells(Target.Row, "H"), _
                                      Sh.Range("I:I"), Cells(Target.Row, "I"), _
                                      Sh.Range("J:J"), Cells(Target.Row, "J"), _
                                      Sh.Range("K:K"), Cells(Target.Row, "K"), _
                                      Sh.Range("L:L"), Cells(Target.Row, "L"), _
                                      Sh.Range("M:M"), Cells(Target.Row, "M"), _
                                      Sh.Range("N:N"), Cells(Target.Row, "N"), _
                                      Sh.Range("O:O"), Cells(Target.Row, "O")) = 0 Then
            Application.ScreenUpdating = False
            Sheets("Arşiv").Unprotect Password:="abc"
            Range("A" & Target.Row & ":Q" & Target.Row).Copy
            Sh.Cells(1048576, "A").End(3)(2, 1).PasteSpecial xlPasteValues
            Sh.Cells(1048576, "A").End(3)(1, 1).PasteSpecial xlPasteFormats
            Sh.Cells(1048576, "P").End(3)(2, 1) = Now
            With Sh.Range("O2:O" & Sh.Cells(1048576, "A").End(3).Row)
                .Formula = "=IF(A1<>A2,"""",(0.0416666666642413*(L2-L1))/(D2-D1))"
                .Value = .Value
            End With
            Application.CutCopyMode = False
            Sheets("Arşiv").Protect Password:="abc", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFiltering:=True
            Application.ScreenUpdating = True
            
        Else
            MsgBox "Bu kayıt daha önce arşiv sayfasına aktarılmıştır.", vbCritical
        End If
        Set Sh = Nothing
    End If
End Sub

Korhan Ayhan · 30 Ekim 2022

Deneyiniz.

C++:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sh As Worksheet
   
    If Intersect(Target, Range("D7:D30")) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
   
    If Target <> "" Then
        Set Sh = Sheets("Arşiv")
        If WorksheetFunction.CountIfs(Sh.Range("A:A"), Cells(Target.Row, "A"), _
                                      Sh.Range("B:B"), Cells(Target.Row, "B"), _
                                      Sh.Range("C:C"), Cells(Target.Row, "C"), _
                                      Sh.Range("D:D"), Cells(Target.Row, "D"), _
                                      Sh.Range("E:E"), Cells(Target.Row, "E"), _
                                      Sh.Range("F:F"), Cells(Target.Row, "F"), _
                                      Sh.Range("G:G"), Cells(Target.Row, "G"), _
                                      Sh.Range("H:H"), Cells(Target.Row, "H"), _
                                      Sh.Range("I:I"), Cells(Target.Row, "I"), _
                                      Sh.Range("J:J"), Cells(Target.Row, "J"), _
                                      Sh.Range("K:K"), Cells(Target.Row, "K"), _
                                      Sh.Range("L:L"), Cells(Target.Row, "L"), _
                                      Sh.Range("M:M"), Cells(Target.Row, "M"), _
                                      Sh.Range("N:N"), Cells(Target.Row, "N"), _
                                      Sh.Range("O:O"), Cells(Target.Row, "O")) = 0 Then
            Application.ScreenUpdating = False
            Sheets("Arşiv").Unprotect Password:="abc"
            Range("A" & Target.Row & ":Q" & Target.Row).Copy
            Sh.Cells(1048576, "A").End(3)(2, 1).PasteSpecial xlPasteValues
            Sh.Cells(1048576, "A").End(3)(1, 1).PasteSpecial xlPasteFormats
            Sh.Cells(1048576, "P").End(3)(2, 1) = Now
            With Sh.Range("O2:O" & Sh.Cells(1048576, "A").End(3).Row)
                .Formula = "=IF(A1<>A2,"""",(0.0416666666642413*(L2-L1))/(D2-D1))"
                .Value = .Value
                .NumberFormat = "#,##0"
            End With
            Sh.Cells.Locked = True
            Application.CutCopyMode = False
            Sheets("Arşiv").Protect Password:="abc", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFiltering:=True
            Application.ScreenUpdating = True
           
        Else
            MsgBox "Bu kayıt daha önce arşiv sayfasına aktarılmıştır.", vbCritical
        End If
        Set Sh = Nothing
    End If
End Sub

Ömer Çakır · 30 Ekim 2022

Çok teşekkürler Korhan Bey,

Elinize sağlık, güzel olmuş.

Çözüldü Geçmiş kayıtları oluşturma

Korhan Ayhan

Administrator

Ömer Çakır

Korhan Ayhan

Administrator

Ömer Çakır

Ömer Çakır

Korhan Ayhan

Administrator

Ömer Çakır