VBA to track changes to a sheet in the same sheet

[jondavis1987]

I was wondering if it's possible to have a vba track changes to a sheet in the same sheet? I have a workbook with 30+ sheets in it. In Cells C5:H5 there's percentages listed. C8:H19 has a bunch of related information. B21:P35 has a chart. Under the chart in B39 I have Date. C39:H39 have names. Is there a vba where when information is changed and then saved in C5 it updates the date in last row of b after Date and then records the new value in C and row whatever the last row of b was? Same thing for D:H5 in their corresponding columns? I've seen a lot of vbas for creating a seperate log sheet or a seperate log workbook. I don't really know how to adapt any of them.

 

[Logit]

.
I don't know about tracking on the same sheet, but here is an example of maintaining changes on a sheet named TRACKER :

Paste this in the ThisWorkbook module :

Option Explicit

Dim vOldVal 'Must be at top of module

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

Dim bBold As Boolean


If Target.Cells.Count > 1 Then Exit Sub

'On Error Resume Next

    With Application
         .ScreenUpdating = False
         .EnableEvents = False

    End With

    If IsEmpty(vOldVal) Then vOldVal = "Empty Cell"
    bBold = Target.HasFormula
        With Sheets("Tracker")
            '.Unprotect Password:="Secret"
                If .Range("A1") = vbNullString Then
                    .Range("A1:F1") = Array("Cell Changed", "Old Value", _
                        "New Value", "Time of Change", "Date of Change", "User")
                End If

            With .Cells(.Rows.Count, 1).End(xlUp)(2, 1)
                  .Value = ActiveSheet.Name & " : " & Target.Address
                  .Offset(0, 1) = vOldVal
            With .Offset(0, 2)
              If bBold = True Then
                .ClearComments
                .AddComment.Text Text:= _
                     "OzGrid.com:" & Chr(10) & "" & Chr(10) & _
                        "Bold values are the results of formulas"

              End If
                .Value = Target
                .Font.Bold = bBold
                
            End With
                .Offset(0, 3) = Time
                .Offset(0, 4) = Date
                .Offset(0, 5) = Application.UserName
            End With
            .Cells.Columns.AutoFit
            '.Protect Password:="Secret"
        End With

    vOldVal = vbNullString

    With Application
         .ScreenUpdating = True
         .EnableEvents = True
    End With
On Error GoTo 0
End Sub


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    vOldVal = Target
End Sub

Private Sub test()
    Application.EnableEvents = True
End Sub

Download example workbook : Track changes Macro.xls

 

[jondavis1987]

The problem is i want all 30+ sheets to be recording their own changes. I don't want to make it a 60+ page workbook where half of the pages are just tracking changes and i don't want it all on one page because that will end up confusing and a lot of information.

 

[Logit]

Consider editing the code so it tracks a single sheet and displays result on that sheet.

 

[Logit]

Keep in mind though, the biggest challenge will be preventing the macro from thinking adding the new changes to the list isn't a change to the sheet.

 

[jondavis1987]

That's why i don't want it to track a whole sheet, just a range. I don't know what i'm looking at in that code enough to change it

 

[Logit]

.

Option Explicit

Public Sub Worksheet_Change(ByVal target As Range)
    Dim intersection As Range
    Set intersection = Intersect(target, Range("A1:B3"))

    If Not intersection Is Nothing Then
        Dim cell As Range

        Application.EnableEvents = False

        For Each cell In intersection
            cell.Value = "Text changed to: " & cell.Value
        Next cell

        Application.EnableEvents = True
    End If
End Sub

How to Tell if a Cell Changed with VBA

 

[Logit]

.
Paste the following in the SHEET module of the affected sheet :

Option Explicit

Dim vOldVal 'Must be at top of module

Private Sub Worksheet_Change(ByVal Target As Range)

Dim bBold As Boolean
Dim c As Range
Set c = Intersect(Range("A1:C10"), Target)  'EDIT AFFECTED RANGE OF CHANGE HERE
If c Is Nothing Then Exit Sub

    If Target.Cells.Count > 1 Then Exit Sub
    
        With Application
    
             .ScreenUpdating = False
    
             .EnableEvents = False
    
        End With
    
        If IsEmpty(vOldVal) Then vOldVal = "Empty Cell"
    
        bBold = Target.HasFormula
    
            With Sheet1
    
                    If .Range("A1") = vbNullString Then
                    
                    'CHANGE LOCATION OF TRACKED CHANGES HERE
                    
                        .Range("A20:E20") = Array("CELL CHANGED", "OLD VALUE", _
                            "NEW VALUE", "TIME OF CHANGE", "DATE OF CHANGE")
    
                    End If
                
                With .Cells(.Rows.Count, 1).End(xlUp)(2, 1)
    
                      .Value = Target.Address
    
                      .Offset(0, 1) = vOldVal
    
                          With .Offset(0, 2)
    
                            If bBold = True Then
    
                              .ClearComments
    
                              .AddComment.Text Text:="OzGrid.com:" & Chr(10) & "" & Chr(10) & "Bold values are the results of formulas"
    
                            End If
    
                              .Value = Target
    
                              .Font.Bold = bBold
    
                          End With
    
                    .Offset(0, 3) = Time
    
                    .Offset(0, 4) = Date
    
                End With
    
                .Cells.Columns.AutoFit
    
            End With
    
        vOldVal = vbNullString
    
        With Application
    
             .ScreenUpdating = True
    
             .EnableEvents = True
    
        End With
    
    On Error GoTo 0

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    vOldVal = Target

End Sub

This is one method of accomplishing what you are seeking.

 

[jondavis1987]

I tried working with that this morning. I was having problems getting it exactly where I wanted it. I realized my problem is I was looking at too broad of a code. I only use this workbook when changing that range and the only time it's saved is when I make changes. So I put a button with this code on every sheet. I appreciate the effort you put in. I just overthought what needed to happen.

Sub Log_Changes()

Dim lastRow As Long

lastRow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row + 1

Range("B" & lastRow).NumberFormat = "mm/dd/yyyy"
Range("C" & lastRow).NumberFormat = "0%"
Range("D" & lastRow).NumberFormat = "0%"
Range("E" & lastRow).NumberFormat = "0%"
Range("F" & lastRow).NumberFormat = "0%"
Range("G" & lastRow).NumberFormat = "0%"
Range("H" & lastRow).NumberFormat = "0%"

ActiveSheet.Range("B39").Copy
ActiveSheet.Range("B" & lastRow).PasteSpecial xlPasteValues
ActiveSheet.Range("C5:H5").Copy
ActiveSheet.Range("C" & lastRow).PasteSpecial xlPasteValues

 If IsEmpty(Range("H3").Value) = True Then
Range("H" & lastRow) = ""
End If

 If IsEmpty(Range("G3").Value) = True Then
Range("G" & lastRow) = ""
End If
 
 If IsEmpty(Range("F3").Value) = True Then
Range("F" & lastRow) = ""
End If

 If IsEmpty(Range("E3").Value) = True Then
Range("E" & lastRow) = ""
End If

 If IsEmpty(Range("D3").Value) = True Then
Range("D" & lastRow) = ""
End If

 If IsEmpty(Range("C3").Value) = True Then
Range("C" & lastRow) = ""
End If

ThisWorkbook.Saved = True

Dim wb As Workbook
Dim win As Window
Dim i As Integer
i = 0
For Each win In Application.Windows
    If win.Visible = True Then
        i = i + 1
    End If
Next win
If i = 1 Then
   Application.DisplayAlerts = True
ThisWorkbook.Save
Application.DisplayAlerts = True
Application.Quit
Else
    ThisWorkbook.Save
    ActiveWorkbook.Close SaveChanges:=True
End If
End Sub

 

[Logit]

Glad you found an answer !