excluding sheets from tracking vba

[Imlooking4sum1lyku]

Hello Newbie here!

Need some help on how to exclude some sheets from tracking (Note: vba was used already to track any changes in the workbook). I had a code and i can post if it is needed. Any help would be much appreciated. Thank you in advance

 

[Biz]

Hi

Please paste your code and mention which sheets you want to exclude.

Biz

 

[Imlooking4sum1lyku]

Hello Biz,

Below is the code from the other user that I adapted in my workbook. I did some modification like adding a borders on the cells. The code is tracking all the changes happen within the workbook. Now, is there a way to track only the specified sheet range/s? (e.g. To track only the following... Sheet2 cell A1:H9, Sheet4 cell D2 & cell F9). Hope there's a way. Thank you.

Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
Dim wSheet As Worksheet
Dim wActSheet As Worksheet
Dim iCol As Integer
Set wActSheet = ActiveSheet
Dim NameOfWorkbook
Dim pw2 As String
pw2 = ""


If vOldValue = "" Then
ElseIf vOldValue <> "" Then
End If
'Continue
On Error Resume Next ' This Error-Resume-Next is only to allow the creation of the tracker sheet (10. History (Back-up)).
Set wSheet = Sheets("10. History (Back-up)")


If wSheet Is Nothing Then
Set wActSheet = ActiveSheet
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "10. History (Back-up)"
End If
On Error GoTo 0
'**** End of specific error resume next

On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
End With

With Sheets("10. History (Back-up)")
If .Cells(1, 1) = "" Then '
iCol = 1 '
Else '
iCol = .Cells(1, 256).End(xlToLeft).Column - 7 '
If Not .Cells(65536, iCol) = "" Then '
iCol = .Cells(1, 256).End(xlToLeft).Column + 1 '
End If '
End If '
'********* END *****************************************************************************'
.Unprotect Password:=pw2

'******** Sets the Column Headers **********************************************************
If LenB(.Cells(1, iCol).Value) = 0 Then
.Range(.Cells(1, iCol), .Cells(1, iCol + 7)) = Array("Cell Changed", "Old Value", _
"New Value", "Old Formula", "New Formula", "Time of Change", "Date of Change", "User")
'Auto-setup
.Cells.Columns.AutoFit
End If

With .Cells(.Rows.Count, iCol).End(xlUp).Offset(1)
'Column A (Cell Changed)
'Getting the current Name of File (w/o extension) as it changes.
NameOfWorkbook = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1))
'sOldAddress = NameOfWorkbook + Active Sheet Name; while #8 is to subtract the remaining excess
.Value = Right(sOldAddress, Len(sOldAddress) - Len(NameOfWorkbook) - 8)
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True

'Column B (Old Value)
.Offset(0, 1).Value = vOldValue
.Offset(0, 1).Borders(xlEdgeLeft).LineStyle = xlContinuous
.Offset(0, 1).Borders(xlEdgeRight).LineStyle = xlContinuous
.Offset(0, 1).Borders(xlEdgeBottom).LineStyle = xlContinuous
.Offset(0, 1).Borders(xlEdgeTop).LineStyle = xlContinuous
.Offset(0, 1).HorizontalAlignment = xlLeft
.Offset(0, 1).VerticalAlignment = xlTop
.Offset(0, 1).WrapText = True
'Column D (Old Formula)
.Offset(0, 3).Value = sOldFormula
.Offset(0, 3).Borders(xlEdgeLeft).LineStyle = xlContinuous
.Offset(0, 3).Borders(xlEdgeRight).LineStyle = xlContinuous
.Offset(0, 3).Borders(xlEdgeBottom).LineStyle = xlContinuous
.Offset(0, 3).Borders(xlEdgeTop).LineStyle = xlContinuous
.Offset(0, 3).HorizontalAlignment = xlLeft
.Offset(0, 3).VerticalAlignment = xlTop
.Offset(0, 3).WrapText = True

If Target.Count = 1 Then
'Column C (New Value)
.Offset(0, 2).Value = Target.Value
.Offset(0, 2).Borders(xlEdgeLeft).LineStyle = xlContinuous
.Offset(0, 2).Borders(xlEdgeRight).LineStyle = xlContinuous
.Offset(0, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous
.Offset(0, 2).Borders(xlEdgeTop).LineStyle = xlContinuous
.Offset(0, 2).HorizontalAlignment = xlLeft
.Offset(0, 2).VerticalAlignment = xlTop
.Offset(0, 2).WrapText = True
If Target.HasFormula Then .Offset(0, 4).Value = "'" & Target.Formula
'Column E (New Formula)
.Offset(0, 4).Borders(xlEdgeLeft).LineStyle = xlContinuous
.Offset(0, 4).Borders(xlEdgeRight).LineStyle = xlContinuous
.Offset(0, 4).Borders(xlEdgeBottom).LineStyle = xlContinuous
.Offset(0, 4).Borders(xlEdgeTop).LineStyle = xlContinuous
.Offset(0, 4).HorizontalAlignment = xlLeft
.Offset(0, 4).VerticalAlignment = xlTop
.Offset(0, 4).WrapText = True

End If
'Column F (Time of Change)
.Offset(0, 5) = Time
.Offset(0, 5).Borders(xlEdgeLeft).LineStyle = xlContinuous
.Offset(0, 5).Borders(xlEdgeRight).LineStyle = xlContinuous
.Offset(0, 5).Borders(xlEdgeBottom).LineStyle = xlContinuous
.Offset(0, 5).Borders(xlEdgeTop).LineStyle = xlContinuous
.Offset(0, 5).HorizontalAlignment = xlCenter
.Offset(0, 5).VerticalAlignment = xlTop
.Offset(0, 5).WrapText = True
'Column G (Date of Change)
.Offset(0, 6) = Date
.Offset(0, 6).NumberFormat = "[$-409]mmm. dd, yyyy;@"
.Offset(0, 6).Borders(xlEdgeLeft).LineStyle = xlContinuous
.Offset(0, 6).Borders(xlEdgeRight).LineStyle = xlContinuous
.Offset(0, 6).Borders(xlEdgeBottom).LineStyle = xlContinuous
.Offset(0, 6).Borders(xlEdgeTop).LineStyle = xlContinuous
.Offset(0, 6).HorizontalAlignment = xlCenter
.Offset(0, 6).VerticalAlignment = xlTop
.Offset(0, 6).WrapText = True

'Column H (User)
.Offset(0, 7) = Application.UserName
.Offset(0, 7).Borders(xlEdgeLeft).LineStyle = xlContinuous
.Offset(0, 7).Borders(xlEdgeRight).LineStyle = xlContinuous
.Offset(0, 7).Borders(xlEdgeBottom).LineStyle = xlContinuous
.Offset(0, 7).Borders(xlEdgeTop).LineStyle = xlContinuous
.Offset(0, 7).HorizontalAlignment = xlLeft
.Offset(0, 7).VerticalAlignment = xlTop
.Offset(0, 7).WrapText = True
End With
.Protect Password:=pw2
End With


ErrorExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With

wActSheet.Activate
Exit Sub

ErrorHandler:
Resume ErrorExit

End Sub