ExcelVBA.Net sitesine katkıda bulunabilirsiniz

[Miraç CAN]

Kod: Tümünü seç

Option Explicit
Private EskiDeger As Variant
Private Durum As Variant
Private Const Gecikme As Date = 10 / 86400
Private Const Onerilen_Zaman As Date = 5 * 60 / 86400
Private Süre As Variant
Private Temps As Date
Private Zaman As Date
Private Sub TimeSlot(Optional Reset As Boolean)
    On Error Resume Next
    Application.OnTime Temps, Procedure:="BuÇalışmaKitabı.TimeSlot", Schedule:=False
    If IsMissing(Reset) Or (Reset = False) Then
        If (Zaman <= Gecikme) Then
            BuÇalışmaKitabı.Close ([False])

            End If
        Zaman = Zaman - Gecikme
    Else
        Zaman = Süre
    End If
    Temps = Now + Gecikme
    Application.OnTime Temps, Procedure:="BuÇalışmaKitabı.TimeSlot"
    ActiveWindow.Caption = Split(ActiveWindow.Caption, " [")(0) & " [" & Zaman & "]"
End Sub
Private Sub Workbook_Open()
    Do
    Loop Until (Süre = False) Or IsDate(Süre)
    Süre = IIf(IsDate(Süre), Süre, Onerilen_Zaman)
    TimeSlot True
Sheets("Log").Range("a65536").End(3)(2, 2).Value = Format(Now(), "hh:mm:ss")
Sheets("Log").Range("a65536").End(3)(2, 3).Value = ActiveSheet.Name
Sheets("Log").Range("a65536").End(3)(2, 7).Value = "giriş yaptı."
Sheets("Log").Range("a65536").End(3)(2, 8).Value = Environ("username")
Sheets("Log").Range("a65536").End(3)(2, 1).Value = Format(Now(), "dd.mm.yyyy dddd")
        Sheets("Log").Range("a65536").End(3).Resize(1, 8).Interior.ColorIndex = 1
        Sheets("Log").Range("a65536").End(3).Resize(1, 8).Font.ColorIndex = 4
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
        Application.OnTime Temps, Procedure:="BuÇalışmaKitabı.TimeSlot", Schedule:=False
Sheets("Log").Range("a65536").End(3)(2, 2).Value = Format(Now(), "hh:mm:ss")
Sheets("Log").Range("a65536").End(3)(2, 3).Value = ActiveSheet.Name
Sheets("Log").Range("a65536").End(3)(2, 7).Value = "çıkış yaptı."
Sheets("Log").Range("a65536").End(3)(2, 8).Value = Environ("username")
Sheets("Log").Range("a65536").End(3)(2, 1).Value = Format(Now(), "dd.mm.yyyy dddd")
        Sheets("Log").Range("a65536").End(3).Resize(1, 8).Interior.ColorIndex = 1
        Sheets("Log").Range("a65536").End(3).Resize(1, 8).Font.ColorIndex = 3
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Application.Caption = ActiveSheet.Name
    If Sheets("Log").Log_CheckBox_1.Value = True Then
    If Sh.Name <> "Log" Then
        Sheets("Log").Range("a65536").End(3)(2, 2).Value = Format(Now(), "hh:mm:ss")
        Sheets("Log").Range("a65536").End(3)(2, 3).Value = Sh.Name
        Sheets("Log").Range("a65536").End(3)(2, 7).Value = "'sayfasını seçti."
        Sheets("Log").Range("a65536").End(3)(2, 8).Value = Environ("username")
        Sheets("Log").Range("a65536").End(3)(2, 1).Value = Format(Now(), "dd.mm.yyyy dddd")
    End If
    Else
    End If
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If IsEmpty(Target.Value) Then Durum = "sildi"
If Selection.Count = 1 Then
If Sh.Name <> "Log" Then
Sheets("Log").Range("a65536").End(3)(2, 2).Value = Format(Now(), "hh:mm:ss")
Sheets("Log").Range("a65536").End(3)(2, 3).Value = Sh.Name
Sheets("Log").Hyperlinks.Add Anchor:=Sheets("Log").Range("a65536").End(3)(2, 4), Address:="", SubAddress:="'" & Sh.Name & "'!" & Target.Address(0, 0), TextToDisplay:=Target.Address(0, 0)
Sheets("Log").Range("a65536").End(3)(2, 5).Value = EskiDeger
Sheets("Log").Range("a65536").End(3)(2, 6).Value = Target.Offset(0, 0).Value
Sheets("Log").Range("a65536").End(3)(2, 7).Value = Durum
Sheets("Log").Range("a65536").End(3)(2, 8).Value = Environ("username")
Sheets("Log").Range("a65536").End(3)(2, 1).Value = Format(Now(), "dd.mm.yyyy dddd")
        Sheets("Log").Range("a65536").End(3)(1, 1).Borders(1).LineStyle = 3
        Sheets("Log").Range("a65536").End(3).Resize(1, 8).Borders(3).LineStyle = 3
        Sheets("Log").Range("a65536").End(3).Resize(1, 8).Borders(4).LineStyle = 3
        Sheets("Log").Range("a65536").End(3).Resize(1, 8).Interior.ColorIndex = 19
        Sheets("Log").Range("a65536").End(3)(1, 8).Borders(2).LineStyle = 3
Else
End If
End If
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    TimeSlot True
    If Sheets("Log").Log_CheckBox_2.Value = True Then
        If Sh.Name <> "Log" Then
            Sheets("Log").Range("a65536").End(3)(2, 2).Value = Format(Now(), "hh:mm:ss")
            Sheets("Log").Range("a65536").End(3)(2, 3).Value = Sh.Name
            Sheets("Log").Hyperlinks.Add Anchor:=Sheets("Log").Range("a65536").End(3)(2, 4), Address:="", SubAddress:="'" & Sh.Name & "'!" & Target.Address(0, 0), TextToDisplay:=Target.Address(0, 0)
            Sheets("Log").Range("a65536").End(3)(2, 7).Value = "'hücresini seçti."
            Sheets("Log").Range("a65536").End(3)(2, 8).Value = Environ("username")
            Sheets("Log").Range("a65536").End(3)(2, 1).Value = Format(Now(), "dd.mm.yyyy dddd")
        End If
        Else
    End If
            If Target.Count > 1 Then Exit Sub
            If Target = "" Then
                EskiDeger = "boş"
            Else: EskiDeger = Target.Value
            End If
     
            If EskiDeger = "boş" Then
                Durum = "'yazdı."
            Else: Durum = "'olarak değiştirdi."
            End If
End Sub

Söylemeyi unuttum. Log kaydı dosyası ThisWorkbook sayfa kodları ile değiştirin.

[mikrenos]

Söylemeyi unuttum. Log kaydı dosyası ThisWorkbook sayfa kodları ile değiştirin.

Teşekkür ederim Miraç Bey. Şuan gözlemlerime göre hem log alıyor hemde sayaç başlangıçta geliyor ve sıkıntısız kapatıyor.

Miraç Bey log kaydı alan kodlar birden çok hücre seçip silindiğinde kayıt almıyor. Örnek olarak A1:A10 siliniyor ancak kayıt düşmüyor. Bu konuda yardımcı olabilir misiniz?

[Miraç CAN]

Söylemeyi unuttum. Log kaydı dosyası ThisWorkbook sayfa kodları ile değiştirin.

Teşekkür ederim Miraç Bey. Şuan gözlemlerime göre hem log alıyor hemde sayaç başlangıçta geliyor ve sıkıntısız kapatıyor.

Miraç Bey log kaydı alan kodlar birden çok hücre seçip silindiğinde kayıt almıyor. Örnek olarak A1:A10 siliniyor ancak kayıt düşmüyor. Bu konuda yardımcı olabilir misiniz?

Declaraitons bölümüne: Private Stp As Boolean, Chng() As Boolean
(Kod sayfasının en üst bölümü, Option Explicit altına)
Aşağıda ki kodları da eksileri ile değiştirin;

Kod: Tümünü seç

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Stp Or Sh.Name Like "Log" Then Exit Sub
Dim R As Range, s%, Trgt As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Sheets("Log").Range("a" & Rows.Count)
For s = LBound(Split(Target.Address(0, 0), ",")) To UBound(Split(Target.Address(0, 0), ","))
    Set Trgt = Range(Split(Target.Address(0, 0), ",")(s))
    If Target.Count > 1 And Chng(s) Then
        .End(3)(2, 2).Value = Format(Now(), "hh:mm:ss")
        .End(3)(2, 3).Value = Sh.Name
        Sheets("Log").Hyperlinks.Add Anchor:=.End(3)(2, 4), Address:="", _
                SubAddress:="'" & Sh.Name & "'!" & Trgt.Address(0, 0), _
                TextToDisplay:=Trgt.Address(0, 0)
        .End(3)(2, 5).Value = EskiDeger(Trgt.Row, Trgt.Column)
        .End(3)(2, 6).Value = Cells(Trgt.Row, Trgt.Column).Value
        .End(3)(2, 7).Value = IIf(IsEmpty(Cells(Trgt.Row, Trgt.Column).Value), "sildi", Durum(Trgt.Row, Trgt.Column))
        .End(3)(2, 8).Value = Environ("username")
        .End(3)(2, 1).Value = Format(Now(), "dd.mm.yyyy dddd")
                .End(3)(1, 1).Borders(1).LineStyle = 3
                .End(3).Resize(1, 8).Borders(3).LineStyle = 3
                .End(3).Resize(1, 8).Borders(4).LineStyle = 3
                .End(3).Resize(1, 8).Interior.ColorIndex = 19
                .End(3)(1, 8).Borders(2).LineStyle = 3
        For Each R In Trgt
            If IsEmpty(R.Value) Then
                EskiDeger(R.Row, R.Column) = "boş"
                Durum(R.Row, R.Column) = "'yazdı."
            Else
                EskiDeger(R.Row, R.Column) = R.Value
                Durum(R.Row, R.Column) = "'olarak değiştirdi."
            End If
        Next R
    Else
        For Each R In Trgt
            .End(3)(2, 2).Value = Format(Now(), "hh:mm:ss")
            .End(3)(2, 3).Value = Sh.Name
            Sheets("Log").Hyperlinks.Add Anchor:=.End(3)(2, 4), Address:="", _
                    SubAddress:="'" & Sh.Name & "'!" & R.Address(0, 0), _
                    TextToDisplay:=R.Address(0, 0)
            .End(3)(2, 5).Value = EskiDeger(R.Row, R.Column)
            .End(3)(2, 6).Value = R.Value
            .End(3)(2, 7).Value = IIf(IsEmpty(R.Value), "sildi", Durum(R.Row, R.Column))
            .End(3)(2, 8).Value = Environ("username")
            .End(3)(2, 1).Value = Format(Now(), "dd.mm.yyyy dddd")
                    .End(3)(1, 1).Borders(1).LineStyle = 3
                    .End(3).Resize(1, 8).Borders(3).LineStyle = 3
                    .End(3).Resize(1, 8).Borders(4).LineStyle = 3
                    .End(3).Resize(1, 8).Interior.ColorIndex = 19
                    .End(3)(1, 8).Borders(2).LineStyle = 3
            If IsEmpty(R.Value) Then
                EskiDeger(R.Row, R.Column) = "boş"
                Durum(R.Row, R.Column) = "'yazdı."
            Else
                EskiDeger(R.Row, R.Column) = R.Value
                Durum(R.Row, R.Column) = "'olarak değiştirdi."
            End If
        Next R
        If Application.CountIf(Trgt, "=" & Cells(Trgt.Row, Trgt.Column).Value) = Trgt.Rows.Count * Trgt.Columns.Count Then _
        Chng(s) = True Else Chng(s) = False
    End If
Next s
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Kod: Tümünü seç

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
TimeSlot True
If Sh.Name Like "Log" Then Exit Sub
Dim R As Range, s%, Trgt As Range
With Sheets("Log").Range("a" & Rows.Count)
    If Sheets("Log").Log_CheckBox_2.Value = True Then
        Stp = True
        .End(3)(2, 1).Value = Format(Now(), "dd.mm.yyyy dddd")
        .End(3)(1, 2).Value = Format(Now(), "hh:mm:ss")
        .End(3)(1, 3).Value = Sh.Name
        Sheets("Log").Hyperlinks.Add Anchor:=.End(3)(1, 4), Address:="", _
        SubAddress:="'" & Sh.Name & "'!" & Split(Target.Address(0, 0), ",")(UBound(Split(Target.Address(0, 0), ","))), _
        TextToDisplay:=Target.Address(0, 0)
        .End(3)(1, 7).Value = IIf((Target.Rows.Count + Target.Columns.Count) > 2, "'hücrelerini seçti.", "'hücresini seçti.")
        .End(3)(1, 8).Value = Environ("username")
        Stp = False
    End If
End With
    ReDim EskiDeger(1 To 2, 0 To UBound(Split(Target.Address(0, 0), ",")))
    ReDim Durum(1 To 2, 0 To UBound(Split(Target.Address(0, 0), ",")))
    ReDim Chng(UBound(Split(Target.Address(0, 0), ",")))
    For s = LBound(Split(Target.Address(0, 0), ",")) To UBound(Split(Target.Address(0, 0), ","))
        Set Trgt = Range(Split(Target.Address(0, 0), ",")(s))
        EskiDeger(1, s) = Trgt.Row: EskiDeger(2, s) = Trgt.Row + Trgt.Rows.Count - 1
        Durum(1, s) = Trgt.Column: Durum(2, s) = Trgt.Column + Trgt.Columns.Count - 1
        If Application.CountIf(Trgt, "=" & Cells(Trgt.Row, Trgt.Column).Value) = Trgt.Rows.Count * Trgt.Columns.Count Then _
        Chng(s) = True Else Chng(s) = False
    Next s
    ReDim EskiDeger(Application.Min(EskiDeger) To Application.Max(EskiDeger), Application.Min(Durum) To Application.Max(Durum))
    ReDim Durum(LBound(EskiDeger, 1) To UBound(EskiDeger, 1), LBound(EskiDeger, 2) To UBound(EskiDeger, 2))
    For Each R In Target
        If IsEmpty(R.Value) Then
            EskiDeger(R.Row, R.Column) = "boş"
            Durum(R.Row, R.Column) = "'yazdı."
        Else
            EskiDeger(R.Row, R.Column) = R.Value
            Durum(R.Row, R.Column) = "'olarak değiştirdi."
        End If
    Next R
End Sub

[mikrenos]

Miraç Bey, yeni deneme fırsatı bulabildim. Şuan sıkıntısız çalışıyor. Elinize sağlık. Hızlı dönüşleriniz izin çok teşekkür ederim.