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

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,249
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
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

Altın Üye
Katılım
20 Ekim 2022
Mesajlar
45
Excel Vers. ve Dili
Office 365
Altın Üyelik Bitiş Tarihi
22-10-2027
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.
 
Son düzenleme:

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,249
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
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

Altın Üye
Katılım
20 Ekim 2022
Mesajlar
45
Excel Vers. ve Dili
Office 365
Altın Üyelik Bitiş Tarihi
22-10-2027
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

Altın Üye
Katılım
20 Ekim 2022
Mesajlar
45
Excel Vers. ve Dili
Office 365
Altın Üyelik Bitiş Tarihi
22-10-2027
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

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,249
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
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

Altın Üye
Katılım
20 Ekim 2022
Mesajlar
45
Excel Vers. ve Dili
Office 365
Altın Üyelik Bitiş Tarihi
22-10-2027
Çok teşekkürler Korhan Bey,

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