Ghi lại lịch sử chỉnh sửa trong Excel

Liên hệ QC
lameco411

lameco411

Thành viên hoạt động
Tham gia
27/11/15
Bài viết
162
Được thích
63
Có bác nào có code ghi lại lịch sử chỉnh sửa của file trong excel không cho em xin với ạ?
Thông tin em cần lấy là:
Ngày giờ, tên máy tính, tên file, tên sheet, địa chỉ cell, nội dung cũ, nội dung mới
Cho em hỏi thêm một cái nữa là nội dung cũ ngoài cách lấy bằng application.undo ra thì em có thấy người ta dùng sự kiện before_doubleclick. Không biết cách này có ổn không, vì khi chỉnh sửa vào file người ta đâu phải click đôi là chỉnh được đâu, Có khi chọn vào rồi gõ luôn, cũng có thể thêm bớt bằng VBA nữa. Bác nào giúp em với ạ
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
lameco411 đã viết:
Có bác nào có code ghi lại lịch sử chỉnh sửa của file trong excel không cho em xin với ạ?
Thông tin em cần lấy là:
Ngày giờ, tên máy tính, tên file, tên sheet, địa chỉ cell, nội dung cũ, nội dung mới
Cho em hỏi thêm một cái nữa là nội dung cũ ngoài cách lấy bằng application.undo ra thì em có thấy người ta dùng sự kiện before_doubleclick. Không biết cách này có ổn không, vì khi chỉnh sửa vào file người ta đâu phải click đôi là chỉnh được đâu, Có khi chọn vào rồi gõ luôn, cũng có thể thêm bớt bằng VBA nữa. Bác nào giúp em với ạ
Nhấp chuột vào đây để mở rộng...
bạn nghiên cứu thử code này xem sao?
tạo một sheets tên history. và copy đoạn code này vào worksheets dữ liệu cần....
Private Sub Worksheet_Change(ByVal Target As Range)
temp = Application.CountA(Sheets("history").Range("a:a")) + 1
Sheets("history").Cells(temp, 1) = Target.Address
Sheets("history").Cells(temp, 2) = Now
Sheets("history").Cells(temp, 3) = Target
Sheets("history").Cells(temp, 4) = Environ("username")
End Sub
 
Upvote 0
chiendich đã viết:
bạn nghiên cứu thử code này xem sao?
tạo một sheets tên history. và copy đoạn code này vào worksheets dữ liệu cần....
Private Sub Worksheet_Change(ByVal Target As Range)
temp = Application.CountA(Sheets("history").Range("a:a")) + 1
Sheets("history").Cells(temp, 1) = Target.Address
Sheets("history").Cells(temp, 2) = Now
Sheets("history").Cells(temp, 3) = Target
Sheets("history").Cells(temp, 4) = Environ("username")
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn, nhưng cái mình cần không có trong code của bạn
 
Upvote 0
chiendich đã viết:
bạn nghiên cứu thử code này xem sao?
tạo một sheets tên history. và copy đoạn code này vào worksheets dữ liệu cần....
Private Sub Worksheet_Change(ByVal Target As Range)
temp = Application.CountA(Sheets("history").Range("a:a")) + 1
Sheets("history").Cells(temp, 1) = Target.Address
Sheets("history").Cells(temp, 2) = Now
Sheets("history").Cells(temp, 3) = Target
Sheets("history").Cells(temp, 4) = Environ("username")
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn nghĩ là có thể tạo ra được 1 sheet tên là "History" hay sao? Bạn thử chưa? Nguyên tắc là tên sheet History bác Bill độc quyền rồi nhưng nếu bạn tạo được thì có lẽ mình bị lạc hậu vì mình chỉ sử dụng Excel 2010
 
Upvote 0
quanghai1969 đã viết:
Bạn nghĩ là có thể tạo ra được 1 sheet tên là "History" hay sao? Bạn thử chưa? Nguyên tắc là tên sheet History bác Bill độc quyền rồi nhưng nếu bạn tạo được thì có lẽ mình bị lạc hậu vì mình chỉ sử dụng Excel 2010
Nhấp chuột vào đây để mở rộng...
Em chỉ giả thiết là history mà quên mất cái tên History của bác bill. xin lỗi đã sai sót.
 
Upvote 0
1. Worksheet_Change có thể sẽ không hoạt động trong trường hợp copy-paste

2. Cái mà thớt muốn, nếu thật sự làm cho đúng thì nó là hình thức của data mirror (cặp đôi dữ liệu). Rất tốn năng lượng máy.
Vì vậy chỉ có thể sử dụng cho trường hợp rất đặc biệt, cả ngàn files mới có một cái cần làm.
 
Upvote 0
VetMini đã viết:
1. Worksheet_Change có thể sẽ không hoạt động trong trường hợp copy-paste

2. Cái mà thớt muốn, nếu thật sự làm cho đúng thì nó là hình thức của data mirror (cặp đôi dữ liệu). Rất tốn năng lượng máy.
Vì vậy chỉ có thể sử dụng cho trường hợp rất đặc biệt, cả ngàn files mới có một cái cần làm.
Nhấp chuột vào đây để mở rộng...
Em sử dụng SQL Server để lưu dữ liệu, dùng Excel để lấy dữ liệu đó về xài. File excel chỉnh sửa gì thì DATA trong SQL cũng thay đổi theo. Vì có nhiều máy chỉnh sửa cùng một dữ liệu nên em muốn biết là máy nào đã chỉnh sửa dữ liệu vào lúc nào, và nội dung cần chỉnh sửa là gì. Chứ không lỡ sai người này đổ thừa người khác rất mệt. Bác có thể nói rõ hơn về cái data miror gì đó không ạ?
 
Upvote 0
Nếu vậy thì bảo SQL Server nó ghi lại thay đổi. Chứ ai lại đi làm ngược, đem công việc kế toán trưởng ra chia cho từng chi nhánh. Rốt cuộc khi kiểm toán hỏi đến thì trả lời "bác muốn kiểm thằng nào để tôi hỏi thằng ấy gởi cho. Chứ ở đây không có giữ hồ sơ"

Đừng hỏi tôi làm cách nào bảo SQL Server nhé. Dùng một phần mềm hạng đó thì phải có trình độ tương đối.
 
Upvote 0
lameco411 đã viết:
Có bác nào có code ghi lại lịch sử chỉnh sửa của file trong excel không cho em xin với ạ?
Thông tin em cần lấy là:
Ngày giờ, tên máy tính, tên file, tên sheet, địa chỉ cell, nội dung cũ, nội dung mới
Cho em hỏi thêm một cái nữa là nội dung cũ ngoài cách lấy bằng application.undo ra thì em có thấy người ta dùng sự kiện before_doubleclick. Không biết cách này có ổn không, vì khi chỉnh sửa vào file người ta đâu phải click đôi là chỉnh được đâu, Có khi chọn vào rồi gõ luôn, cũng có thể thêm bớt bằng VBA nữa. Bác nào giúp em với ạ
Nhấp chuột vào đây để mở rộng...
Thử cái này chơi chơi
***************Lưu ý**************************:
1. Code dưới chỉ là ví dụ để thấy code ghi lại hoạt động. Không nên ghi lịch sử hoạt động trực tiếp vào 1 worksheets - ví dụ code dưới: .Range("A" & LR + 1).Value = Now, các lệnh ghi hoạt động như thế này cần bỏ đi , có thể ghi nó vào textbox / code module hoặc một file txt / log / Database / .... Để có thể sử dụng Undo / Redo sau khi events xảy ra.
Hoặc Vẫn có thể ghi vào một worksheets , Undo / Redo vẫn có hoạt động nếu tạo một Classmodule Undo "tay" (tức là hàm tự viết hoặc tìm trên Google, thử tìm thế này xem: "Undo Handler VBA", "Undo Events VBA")

2. Trong Events, Nhớ dùng bẩy lỗi để đi đến :
'Nếu đã dùng:
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Dùng bẫy lỗi
'Nếu lỗi thì đến đây
With Application
.EnableEvents = True
.ScreenUpdating = True
End With

3. Code dưới chỉ đơn giản ghi lại một số Hoạt động thường làm , muốn hơn thì phải:
Khi Event Change thì Debug.Print "SheetChange - " & lastActionEvents trả về các hoạt động,
xem hoạt động nào khác cần ghi lại thì cứ thêm một cụm ElseIf,
còn nhiều Hoạt động nâng cao khác như: undo , redo, ....

Copy code sau vào Code của Workbook
PHP: 
Option Explicit
Dim strValueRangeRecent As String
Dim strAddressRange As String
Dim strAddressRangeRecent As String
Dim strNameSheetRecent As String
Dim lastActionEvents As String
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    strAddressRangeRecent = strAddressRange
    strAddressRange = vbNullString
    strNameSheetRecent = vbNullString
    strValueRangeRecent = vbNullString
    If Target.Count = 1 Then strValueRangeRecent = Target.Value
    strAddressRange = Target.Address(False, False)
    strNameSheetRecent = Sh.Name
End Sub


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    On Local Error Resume Next
    Dim c As Range, LR As Long
    On Error Resume Next
    lastActionEvents = Application.CommandBars("Standard").Controls("&Undo").List(1)
    If Err.Number <> 0 Then lastActionEvents = "UnKnown"
    On Error GoTo 0
    Debug.Print "SheetChange - " & lastActionEvents
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Dim wSheet As Worksheet, dup_NameSheet As Boolean
    For Each wSheet In Worksheets
        If wSheet.Name = "RecentLog" Then dup_NameSheet = True: Exit For
    Next wSheet
    If dup_NameSheet = False Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "RecentLog"

    With Sheets("RecentLog")
        'Ẩn Sheet đi và Mở Khóa
       ' .Visible = xlSheetVeryHidden ' (Hiện lại bằng VBA) với xlSheetHidden (Có thể hiện lại bằng tay)
       ' .Unprotect Password:="123"

        .[A1:H1].Value = (Array("Time", "Action", "From", "To", "Before", "After", "User", "FilePath"))
        Dim strShNameTarget As String, strShNameRecent As String, strRangeShNameRecent As String, strRngShNameRecent As String
        strShNameTarget = "Sheets(""" & Sh.Name & """).Range(""" & Target.Address(False, False) & """)"
        strRangeShNameRecent = "Sheets(""" & Sh.Name & """).Range(""" & strAddressRange & """)"
        strShNameRecent = "Sheets(""" & strNameSheetRecent & """).Range(""" & strAddressRangeRecent & """)"
        strRngShNameRecent = "Sheets(""" & Sh.Name & """).Range(""" & strAddressRangeRecent & """)"

        LR = .Range("A" & Rows.Count).End(xlUp).Row
        If lastActionEvents <> "UnKnown" Then
            .Range("A" & LR + 1).Value = Now
            .Range("G" & LR + 1).Value = Environ("username")
            .Range("H" & LR + 1).Value = ThisWorkbook.FullName
            If lastActionEvents = "Auto Fill" Then
                .Range("B" & LR + 1).Value = "Auto Fill"
                .Range("C" & LR + 1).Value = strRngShNameRecent
                .Range("D" & LR + 1).Value = strShNameTarget
            ElseIf lastActionEvents = "Fill" Then
                '.......
            ElseIf lastActionEvents = "Justify" Then
                '.......
            ElseIf lastActionEvents = "Fill Up" Then
                '.......
            ElseIf lastActionEvents = "Fill Left" Then
                '.......
           ' ElseIf lastActionEvents = "Paste Special" Then
                '.Range("B" & LR + 1).Value = "Paste"
                '.Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf Left(lastActionEvents, 5) = "Paste" Then
                .Range("B" & LR + 1).Value = lastActionEvents
                If Target.Count <> 1 Then
                    If strAddressRangeRecent = vbNullString Then GoTo CountRange
                    If Range(strAddressRangeRecent).Rows.Count = Target.Rows.Count _
                    And Range(strAddressRangeRecent).Columns.Count = Target.Columns.Count Then
                        .Range("C" & LR + 1).Value = strShNameRecent
                        .Range("D" & LR + 1).Value = strShNameTarget

                    Else
CountRange:
                        .Range("C" & LR + 1).Value = "Unknown"
                        .Range("D" & LR + 1).Value = strShNameTarget
                    End If
                Else

                    .Range("C" & LR + 1).Value = strShNameRecent
                    .Range("D" & LR + 1).Value = strShNameTarget
                End If
            ElseIf lastActionEvents = "Insert Cells" Then
                .Range("B" & LR + 1).Value = "Insert Cells"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Copied Cells" Then
                .Range("B" & LR + 1).Value = "Insert Copy"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Sort" Then
                .Range("B" & LR + 1).Value = "Sort"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Clear" Then
                .Range("B" & LR + 1).Value = "Clear"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Delete" Then
                .Range("B" & LR + 1).Value = "Delete"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Paste Link" Then
                .Range("B" & LR + 1).Value = "Paste Link"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Values  Source Formatting" Then
                .Range("B" & LR + 1).Value = "Values  Source Formatting"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Keep Source Formatting" Then
                .Range("B" & LR + 1).Value = "Keep Source Formatting"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents Like "Typing * in *" Then
                .Range("D" & LR + 1).Value = strShNameTarget
                .Range("F" & LR + 1).Value = Target.Value
                If Target.HasFormula Then
                    .Range("B" & LR + 1).Value = "Add Formula"
                    .Range("F" & LR + 1).Value = "'" & CStr(Target.Formula)
                End If
                .Range("B" & LR + 1).Value = "Edit Cells"
                .Range("D" & LR + 1).NumberFormat = "@"
                .Range("E" & LR + 1).Value = strValueRangeRecent
            Else
                '.Range("B" & LR + 1).Value = "Unknown - " & lastActionEvents
                Debug.Print "Unknown - " & lastActionEvents
            End If
        End If

        'Nếu đã ẩn thì Hiện Sheet
        ' .Visible = xlSheetVisible
       ' Khóa lại
       ' .Protect Password:="123", DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
        :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
        AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    End With
    strAddressRange = vbNullString
    strNameSheetRecent = vbNullString
    strValueRangeRecent = vbNullString
    strAddressRangeRecent = vbNullString
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
VetMini đã viết:
1. Worksheet_Change có thể sẽ không hoạt động trong trường hợp copy-paste

2. Cái mà thớt muốn, nếu thật sự làm cho đúng thì nó là hình thức của data mirror (cặp đôi dữ liệu). Rất tốn năng lượng máy.
Vì vậy chỉ có thể sử dụng cho trường hợp rất đặc biệt, cả ngàn files mới có một cái cần làm.
Nhấp chuột vào đây để mở rộng...
Chào bác @VetMini , Không biết #9 đã đạt yêu cầu thứ nhất hay chưa
 
Lần chỉnh sửa cuối:
Upvote 0
minahnh0011 đã viết:
Thử cái này chơi chơi
***************Lưu ý**************************:
1. Code dưới chỉ là ví dụ để thấy code ghi lại hoạt động. Không nên ghi lịch sử hoạt động trực tiếp vào 1 worksheets - ví dụ code dưới: .Range("A" & LR + 1).Value = Now, các lệnh ghi hoạt động như thế này cần bỏ đi , có thể ghi nó vào textbox / code module hoặc một file txt / log / Database / .... Để có thể sử dụng Undo / Redo sau khi events xảy ra.
Hoặc Vẫn có thể ghi vào một worksheets , Undo / Redo vẫn có hoạt động nếu tạo một Classmodule Undo "tay" (tức là hàm tự viết hoặc tìm trên Google, thử tìm thế này xem: "Undo Handler VBA", "Undo Events VBA")

2. Trong Events, Nhớ dùng bẩy lỗi để đi đến :
'Nếu đã dùng:
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Dùng bẫy lỗi
'Nếu lỗi thì đến đây
With Application
.EnableEvents = True
.ScreenUpdating = True
End With

3. Code dưới chỉ đơn giản ghi lại một số Hoạt động thường làm , muốn hơn thì phải:
Khi Event Change thì Debug.Print "SheetChange - " & lastActionEvents trả về các hoạt động,
xem hoạt động nào khác cần ghi lại thì cứ thêm một cụm ElseIf,
còn nhiều Hoạt động nâng cao khác như: undo , redo, ....

Copy code sau vào Code của Workbook
Mã: 
Option Explicit
Dim strValueRangeRecent As String
Dim strAddressRange As String
Dim strAddressRangeRecent As String
Dim strNameSheetRecent As String
Dim lastActionEvents As String
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    strAddressRangeRecent = strAddressRange
    strAddressRange = vbNullString
    strNameSheetRecent = vbNullString
    strValueRangeRecent = vbNullString
    If Target.Count = 1 Then strValueRangeRecent = Target.Value
    strAddressRange = Target.Address(False, False)
    strNameSheetRecent = Sh.Name
End Sub


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    On Local Error Resume Next
    Dim c As Range, LR As Long
    On Error Resume Next
    lastActionEvents = Application.CommandBars("Standard").Controls("&Undo").List(1)
    If Err.Number <> 0 Then lastActionEvents = "UnKnown"
    On Error GoTo 0
    Debug.Print "SheetChange - " & lastActionEvents
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Dim wSheet As Worksheet, dup_NameSheet As Boolean
    For Each wSheet In Worksheets
        If wSheet.Name = "RecentLog" Then dup_NameSheet = True: Exit For
    Next wSheet
    If dup_NameSheet = False Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "RecentLog"

    With Sheets("RecentLog")
        'Ẩn Sheet đi và Mở Khóa
       ' .Visible = xlSheetVeryHidden ' (Hiện lại bằng VBA) với xlSheetHidden (Có thể hiện lại bằng tay)
       ' .Unprotect Password:="123"

        .[A1:H1].Value = (Array("Time", "Action", "From", "To", "Before", "After", "User", "FilePath"))
        Dim strShNameTarget As String, strShNameRecent As String, strRangeShNameRecent As String, strRngShNameRecent As String
        strShNameTarget = "Sheets(""" & Sh.Name & """).Range(""" & Target.Address(False, False) & """)"
        strRangeShNameRecent = "Sheets(""" & Sh.Name & """).Range(""" & strAddressRange & """)"
        strShNameRecent = "Sheets(""" & strNameSheetRecent & """).Range(""" & strAddressRangeRecent & """)"
        strRngShNameRecent = "Sheets(""" & Sh.Name & """).Range(""" & strAddressRangeRecent & """)"

        LR = .Range("A" & Rows.Count).End(xlUp).Row
        If lastActionEvents <> "UnKnown" Then
            .Range("A" & LR + 1).Value = Now
            .Range("G" & LR + 1).Value = Environ("username")
            .Range("H" & LR + 1).Value = ThisWorkbook.FullName
            If lastActionEvents = "Auto Fill" Then
                .Range("B" & LR + 1).Value = "Auto Fill"
                .Range("C" & LR + 1).Value = strRngShNameRecent
                .Range("D" & LR + 1).Value = strShNameTarget
            ElseIf lastActionEvents = "Fill" Then
                '.......
            ElseIf lastActionEvents = "Justify" Then
                '.......
            ElseIf lastActionEvents = "Fill Up" Then
                '.......
            ElseIf lastActionEvents = "Fill Left" Then
                '.......
           ' ElseIf lastActionEvents = "Paste Special" Then
                '.Range("B" & LR + 1).Value = "Paste"
                '.Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf Left(lastActionEvents, 5) = "Paste" Then
                .Range("B" & LR + 1).Value = lastActionEvents
                If Target.Count <> 1 Then
                    If strAddressRangeRecent = vbNullString Then GoTo CountRange
                    If Range(strAddressRangeRecent).Rows.Count = Target.Rows.Count _
                    And Range(strAddressRangeRecent).Columns.Count = Target.Columns.Count Then
                        .Range("C" & LR + 1).Value = strShNameRecent
                        .Range("D" & LR + 1).Value = strShNameTarget

                    Else
CountRange:
                        .Range("C" & LR + 1).Value = "Unknown"
                        .Range("D" & LR + 1).Value = strShNameTarget
                    End If
                Else

                    .Range("C" & LR + 1).Value = strShNameRecent
                    .Range("D" & LR + 1).Value = strShNameTarget
                End If
            ElseIf lastActionEvents = "Insert Cells" Then
                .Range("B" & LR + 1).Value = "Insert Cells"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Copied Cells" Then
                .Range("B" & LR + 1).Value = "Insert Copy"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Sort" Then
                .Range("B" & LR + 1).Value = "Sort"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Clear" Then
                .Range("B" & LR + 1).Value = "Clear"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Delete" Then
                .Range("B" & LR + 1).Value = "Delete"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Paste Link" Then
                .Range("B" & LR + 1).Value = "Paste Link"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Values  Source Formatting" Then
                .Range("B" & LR + 1).Value = "Values  Source Formatting"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Keep Source Formatting" Then
                .Range("B" & LR + 1).Value = "Keep Source Formatting"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents Like "Typing * in *" Then
                .Range("D" & LR + 1).Value = strShNameTarget
                .Range("F" & LR + 1).Value = Target.Value
                If Target.HasFormula Then
                    .Range("B" & LR + 1).Value = "Add Formula"
                    .Range("F" & LR + 1).Value = "'" & CStr(Target.Formula)
                End If
                .Range("B" & LR + 1).Value = "Edit Cells"
                .Range("D" & LR + 1).NumberFormat = "@"
                .Range("E" & LR + 1).Value = strValueRangeRecent
            Else
                '.Range("B" & LR + 1).Value = "Unknown - " & lastActionEvents
                Debug.Print "Unknown - " & lastActionEvents
            End If
        End If

        'Nếu đã ẩn thì Hiện Sheet
        ' .Visible = xlSheetVisible
       ' Khóa lại
       ' .Protect Password:="123", DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
        :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
        AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    End With
    strAddressRange = vbNullString
    strNameSheetRecent = vbNullString
    strValueRangeRecent = vbNullString
    strAddressRangeRecent = vbNullString
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
Nhấp chuột vào đây để mở rộng...
Sau khi đọc code của bác em bị tăng huyết áp chút, để em từ từ nghiên cứu ạ!
 
Upvote 0
minahnh0011 đã viết:
Thử cái này chơi chơi
***************Lưu ý**************************:
1. Code dưới chỉ là ví dụ để thấy code ghi lại hoạt động. Không nên ghi lịch sử hoạt động trực tiếp vào 1 worksheets - ví dụ code dưới: .Range("A" & LR + 1).Value = Now, các lệnh ghi hoạt động như thế này cần bỏ đi , có thể ghi nó vào textbox / code module hoặc một file txt / log / Database / .... Để có thể sử dụng Undo / Redo sau khi events xảy ra.
Hoặc Vẫn có thể ghi vào một worksheets , Undo / Redo vẫn có hoạt động nếu tạo một Classmodule Undo "tay" (tức là hàm tự viết hoặc tìm trên Google, thử tìm thế này xem: "Undo Handler VBA", "Undo Events VBA")

2. Trong Events, Nhớ dùng bẩy lỗi để đi đến :
'Nếu đã dùng:
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Dùng bẫy lỗi
'Nếu lỗi thì đến đây
With Application
.EnableEvents = True
.ScreenUpdating = True
End With

3. Code dưới chỉ đơn giản ghi lại một số Hoạt động thường làm , muốn hơn thì phải:
Khi Event Change thì Debug.Print "SheetChange - " & lastActionEvents trả về các hoạt động,
xem hoạt động nào khác cần ghi lại thì cứ thêm một cụm ElseIf,
còn nhiều Hoạt động nâng cao khác như: undo , redo, ....

Copy code sau vào Code của Workbook
Mã: 
Option Explicit
Dim strValueRangeRecent As String
Dim strAddressRange As String
Dim strAddressRangeRecent As String
Dim strNameSheetRecent As String
Dim lastActionEvents As String
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    strAddressRangeRecent = strAddressRange
    strAddressRange = vbNullString
    strNameSheetRecent = vbNullString
    strValueRangeRecent = vbNullString
    If Target.Count = 1 Then strValueRangeRecent = Target.Value
    strAddressRange = Target.Address(False, False)
    strNameSheetRecent = Sh.Name
End Sub


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    On Local Error Resume Next
    Dim c As Range, LR As Long
    On Error Resume Next
    lastActionEvents = Application.CommandBars("Standard").Controls("&Undo").List(1)
    If Err.Number <> 0 Then lastActionEvents = "UnKnown"
    On Error GoTo 0
    Debug.Print "SheetChange - " & lastActionEvents
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Dim wSheet As Worksheet, dup_NameSheet As Boolean
    For Each wSheet In Worksheets
        If wSheet.Name = "RecentLog" Then dup_NameSheet = True: Exit For
    Next wSheet
    If dup_NameSheet = False Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "RecentLog"

    With Sheets("RecentLog")
        'Ẩn Sheet đi và Mở Khóa
       ' .Visible = xlSheetVeryHidden ' (Hiện lại bằng VBA) với xlSheetHidden (Có thể hiện lại bằng tay)
       ' .Unprotect Password:="123"

        .[A1:H1].Value = (Array("Time", "Action", "From", "To", "Before", "After", "User", "FilePath"))
        Dim strShNameTarget As String, strShNameRecent As String, strRangeShNameRecent As String, strRngShNameRecent As String
        strShNameTarget = "Sheets(""" & Sh.Name & """).Range(""" & Target.Address(False, False) & """)"
        strRangeShNameRecent = "Sheets(""" & Sh.Name & """).Range(""" & strAddressRange & """)"
        strShNameRecent = "Sheets(""" & strNameSheetRecent & """).Range(""" & strAddressRangeRecent & """)"
        strRngShNameRecent = "Sheets(""" & Sh.Name & """).Range(""" & strAddressRangeRecent & """)"

        LR = .Range("A" & Rows.Count).End(xlUp).Row
        If lastActionEvents <> "UnKnown" Then
            .Range("A" & LR + 1).Value = Now
            .Range("G" & LR + 1).Value = Environ("username")
            .Range("H" & LR + 1).Value = ThisWorkbook.FullName
            If lastActionEvents = "Auto Fill" Then
                .Range("B" & LR + 1).Value = "Auto Fill"
                .Range("C" & LR + 1).Value = strRngShNameRecent
                .Range("D" & LR + 1).Value = strShNameTarget
            ElseIf lastActionEvents = "Fill" Then
                '.......
            ElseIf lastActionEvents = "Justify" Then
                '.......
            ElseIf lastActionEvents = "Fill Up" Then
                '.......
            ElseIf lastActionEvents = "Fill Left" Then
                '.......
           ' ElseIf lastActionEvents = "Paste Special" Then
                '.Range("B" & LR + 1).Value = "Paste"
                '.Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf Left(lastActionEvents, 5) = "Paste" Then
                .Range("B" & LR + 1).Value = lastActionEvents
                If Target.Count <> 1 Then
                    If strAddressRangeRecent = vbNullString Then GoTo CountRange
                    If Range(strAddressRangeRecent).Rows.Count = Target.Rows.Count _
                    And Range(strAddressRangeRecent).Columns.Count = Target.Columns.Count Then
                        .Range("C" & LR + 1).Value = strShNameRecent
                        .Range("D" & LR + 1).Value = strShNameTarget

                    Else
CountRange:
                        .Range("C" & LR + 1).Value = "Unknown"
                        .Range("D" & LR + 1).Value = strShNameTarget
                    End If
                Else

                    .Range("C" & LR + 1).Value = strShNameRecent
                    .Range("D" & LR + 1).Value = strShNameTarget
                End If
            ElseIf lastActionEvents = "Insert Cells" Then
                .Range("B" & LR + 1).Value = "Insert Cells"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Copied Cells" Then
                .Range("B" & LR + 1).Value = "Insert Copy"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Sort" Then
                .Range("B" & LR + 1).Value = "Sort"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Clear" Then
                .Range("B" & LR + 1).Value = "Clear"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Delete" Then
                .Range("B" & LR + 1).Value = "Delete"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Paste Link" Then
                .Range("B" & LR + 1).Value = "Paste Link"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Values  Source Formatting" Then
                .Range("B" & LR + 1).Value = "Values  Source Formatting"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents = "Keep Source Formatting" Then
                .Range("B" & LR + 1).Value = "Keep Source Formatting"
                .Range("C" & LR + 1).Value = strRangeShNameRecent
            ElseIf lastActionEvents Like "Typing * in *" Then
                .Range("D" & LR + 1).Value = strShNameTarget
                .Range("F" & LR + 1).Value = Target.Value
                If Target.HasFormula Then
                    .Range("B" & LR + 1).Value = "Add Formula"
                    .Range("F" & LR + 1).Value = "'" & CStr(Target.Formula)
                End If
                .Range("B" & LR + 1).Value = "Edit Cells"
                .Range("D" & LR + 1).NumberFormat = "@"
                .Range("E" & LR + 1).Value = strValueRangeRecent
            Else
                '.Range("B" & LR + 1).Value = "Unknown - " & lastActionEvents
                Debug.Print "Unknown - " & lastActionEvents
            End If
        End If

        'Nếu đã ẩn thì Hiện Sheet
        ' .Visible = xlSheetVisible
       ' Khóa lại
       ' .Protect Password:="123", DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
        :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
        AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    End With
    strAddressRange = vbNullString
    strNameSheetRecent = vbNullString
    strValueRangeRecent = vbNullString
    strAddressRangeRecent = vbNullString
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
Nhấp chuột vào đây để mở rộng...

Xin chào minahnh0011,
OT có thể order thêm mục ghi lại thông tin thêm,sửa xóa sheet được không ạ ? :)
 
Upvote 0
minahnh0011 đã viết:
sửa Tên Sheet, thuộc tính sheets ? -> Nguyễn Hoàng Oanh Thơ
Nhấp chuột vào đây để mở rộng...
Dùng Events này nhé OT
Không biết là máy cái cơ bản get Properties ở dưới OT biết chưa
Mã: 
Dim oldNameSheet as String
Dim oldProperties...1 as String
Dim oldProperties...2 as String
'Hoặc dùng Dim ... As new Collection gán old Properties'
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    'bắt name sheet ở đây
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
    'tìm lại name sheet có còn không'
    'duyệt Collection get thuộc tính'
End Sub
Private Sub Workbook_NewSheet(ByVal Sh As Object)
       'Thêm
End Sub
Private Sub Workbook_SheetBeforeDelete(ByVal Sh As Object)
       '  
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
minahnh0011 đã viết:
Dùng Events này nhé OT
Không biết là máy cái cơ bản get Properties ở dưới OT biết chưa
Mã: 
Dim oldNameSheet as String
Dim oldProperties...1 as String
Dim oldProperties...2 as String
'Hoặc dùng Dim ... As new Collection gán old Properties'
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    'bắt name sheet ở đây
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
    'tìm lại name sheet có còn không'
    'duyệt Collection get thuộc tính'
End Sub
Private Sub Workbook_NewSheet(ByVal Sh As Object)
       'Thêm
End Sub
Private Sub Workbook_SheetBeforeDelete(ByVal Sh As Object)
       '
End Sub
Nhấp chuột vào đây để mở rộng...

Cảm ơn minahnh0011 nhiều, OT hiểu rồi.
Vậy là cần thêm gì thì cứ gọi sự kiện đó ra? :)
 
Upvote 0
minahnh0011 đã viết:
OT cho tôi hỏi về:
1. Làm sao đổi cái tên Nguyễn Hoàng Oanh Thơ
2. Làm sao có chữ ký tin nhắn
Nhấp chuột vào đây để mở rộng...

Dạ,..cái này.. là vi phạm nội qui thì phải ,hình nội qui muốn hỏi thêm gì thì lập chủ đề khác hây sao ấy ạ :D
1. Làm sao đổi cái tên Nguyễn Hoàng Oanh Thơ
Nhấp chuột vào đây để mở rộng...
Đó là tên nickName OT đặt khi lập nick ạ, hình như cái này muốn đổi thì phải liên hệ với các anh có tên nick tô màu đỏ minahnh0011 ạ.
còn:
2. Làm sao có chữ ký tin nhắn
Nhấp chuột vào đây để mở rộng...
Thì vào phần quản lý , cài đặt thông tin của tài khoản thiết lập được ạ.
Chắc minahnh0011 không có gì để hỏi nên mới hỏi vui vậy chứ? :)

------------
Híc OT vừa vào phần thiết lập tài khoản không thấy mục chữ ký ạ.
Có thể OT tạo từ ngày mới lập nick nên có, còn bây giờ giao diện mới thay đổi chắc anh @Hai Lúa Miền Tây cắt bớt, tiết kiệm để giảm tải cho Server đỡ nặng hay sao ý ạ :D
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

phammaihuong90
Hàm tìm ngày gần nhất đạt được số lượng mục tiêu
Trả lời
4
Đọc
37
phammaihuong90
phammaihuong90
H
TÍNH PHÉP NĂM CHO NHÂN VIÊN
Trả lời
2
Đọc
83
bebo021999
B
O
Kết hợp hàm value
Trả lời
1
Đọc
29
bebo021999
B
ongke0711
  • Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • Thích
    • Yêu thích
    • Cảm ơn
10 11 12
Trả lời
225
Đọc
18K
ongke0711
ongke0711
T
  • Question
Cho mình hỏi tại sao file mình chạy Sao lưu lại bị đầy bộ nhớ.
Trả lời
2
Đọc
63
thientan201
T
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom