How to record a sheet change showing row column sheet name and date?
 

Hi all,

Can anyone help with this one? I want to be able to record when a cel
is changed on a sheet and the record to be entered in a workbook tha
is unopened (and doesnt need to be) in the format of showing Row
Column? sheet name and date it occurred, this is so administration ca
keep track of changes to rectify mistakes and make sure changes occu
in due course. I already have some code in the worksheet selectio
change event to bring up a user form and for other events to happen a
below. Also below is the code from the This Workbook module.

Hope you can help!

Simon

Here's the code

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim sh As Object
Dim myrange As Range
Dim ComboBox1
Dim I1 As Integer
Dim res As Variant
Dim arySheets
On Error Resume Next


With arySheets

Set myrange = Range("E3:H641")
If Not Intersect(myrange, Target) Is Nothing Then

ActiveWindow.ScrollWorkbookTabs Position:=xlLast
arySheets = Array("Corn Process", "Alpha Process", "Bulk
H&I", _
"Alpha Packing", "33 Bldg Packing", "Ctd Cor
Packing", _
"2 & 3 Coating", "Crispix", "Feed&Lab"
"Flavour", _
"Jet Zones", "Quality & Others", "MPD"
"Plant Awareness", _
"Rice Cooking", "Vehicle Drivers (plant)"
"VIP", _
"15-21 & 22", "4&5 Coating", "Tank Floor 15
33 Bldg", "FSP's ")

Sheets(arySheets).Select

For Each sh In ActiveWorkbook.Worksheets
sh.Unprotect
Next
End If

If ActiveCell.Column = 5 And ActiveCell.Column <= 8 An
ActiveCell.Row = 3 And ActiveCell.Row <= 641 Then
UserForm1.Show
If Not IsError(res) Then

ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
Worksheets("hidden").Visible = False
Me.Select

End If

If ActiveCell < "shift " Then
Range("A" & ActiveCell.Row).Select
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst

End If
End If

End With


End Sub

Option Explicit


Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVa
Target As Range)
Dim valstr
Dim fValid As Boolean
Dim valint As Integer

On Error GoTo ws_exit:
Application.EnableEvents = False

If Not Intersect(Target, sh.Range("Skills" & sh.Index)) Is Nothin
Then

valstr = InputBox("Enter Skill Level" & vbCrLf & _
Space(5) & "1 = In Training" & vbCrLf & _
Space(5) & "2 = Trained" & vbCrLf & _
Space(5) & "3 = Can Train Others" & vbCrL
& _
Space(5) & "4 = Delete Colour and Entry"
_
"Skills Breakdown and Competencies Entry"
"")
valint = Val(valstr)

If valint = 0 Then

Application.EnableEvents = True
sh.Protect

Exit Sub

End If

With Target
sh.Unprotect

Select Case valint
Case 1: .Interior.ColorIndex = 48
Case 2: .Interior.ColorIndex = 33
Case 3: .Interior.ColorIndex = 6
Case 4: .Interior.ColorIndex = xlNone
.Value = ""

Case Else: MsgBox "Invalid Entry Try Again!"

End Select
If valint = 4 Then
With Target
sh.Cells(.Row, .Column + kTestColOff).Value = ""
End With
Else
CheckCondition Target, sh
End If
'sh.Range("A" & .Row).Select
End With


End If

ws_exit:
Application.EnableEvents = True

End Sub

Private Sub CheckCondition(ByVal Target As Range, ByVal sh As Object)

Dim rngtest As Range

With Target
Set rngtest = sh.Cells(.Row, .Column + kTestColOff)
If rngtest = "" Then
.Font.ColorIndex = kColorTest1
.Value = "h"

End If
rngtest.Value = ""
End With

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim lDat_Today As Date
Dim lDat_Tomorrow As Date
Dim sStr As String
Dim myattr

With ThisWorkbook
'Check ReadOnly status to establish if
'this is a backup copy
'If GetAttr(.Name) And vbReadOnly = 1 Then Exit Sub
If ActiveWorkbook.ReadOnly Then Exit Sub
lDat_Today = Date
If Format(Date, "ddd") = "Fri" Then
lDat_Tomorrow = Date + 3
Else
lDat_Tomorrow = Date + 1
End If

If Not Month(lDat_Today) = Month(lDat_Tomorrow) Then
sStr = .Path & "\" & _
Left(.Name, InStr(1, _
LCase(.Name), _
".xls") - 1) & _
" - " & Format(Now, "yyyymmdd") & ".xls"
On Error Resume Next
SaveCopyAs sStr
On Error GoTo 0
SetAttr sStr, vbReadOnly
End If
End With
End Sub


--
Simon Lloyd
------------------------------------------------------------------------
Simon Lloyd's Profile: http://www.excelforum.com/member.php...fo&userid=6708
View this thread: http://www.excelforum.com/showthread...hreadid=266360

How to record a sheet change showing row column sheet name and date?
 

Detecting a change is the Worksheet_Change event, or workbook
Workbook_SheetChange event. You can test for a range of cells in this

Open a workbook is simply

If oWBAudit Is Nothing Then
Set oWBAudit = Workbooks.Open Filename:="C:\Audit\Tracking.xls"
End IF


writing the change is simply a matter of addig something like

with oWBAudit.Worksheets(1).Cells(Rows.Count,"A").End(x lUp)
.Offset(1,0).Value = Tarfget.Value
.Offset(1,1).Value = Format(Date,"dd mmm yyyy")
.Offset(1,2).Value = Application.UserName
End With

--

HTH

RP

"Simon Lloyd" wrote in message
...

Hi all,

Can anyone help with this one? I want to be able to record when a cell
is changed on a sheet and the record to be entered in a workbook that
is unopened (and doesnt need to be) in the format of showing Row?
Column? sheet name and date it occurred, this is so administration can
keep track of changes to rectify mistakes and make sure changes occur
in due course. I already have some code in the worksheet selection
change event to bring up a user form and for other events to happen as
below. Also below is the code from the This Workbook module.

Hope you can help!

Simon

Here's the code

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim sh As Object
Dim myrange As Range
Dim ComboBox1
Dim I1 As Integer
Dim res As Variant
Dim arySheets
On Error Resume Next


With arySheets

Set myrange = Range("E3:H641")
If Not Intersect(myrange, Target) Is Nothing Then

ActiveWindow.ScrollWorkbookTabs Position:=xlLast
arySheets = Array("Corn Process", "Alpha Process", "Bulk &
H&I", _
"Alpha Packing", "33 Bldg Packing", "Ctd Corn
Packing", _
"2 & 3 Coating", "Crispix", "Feed&Lab",
"Flavour", _
"Jet Zones", "Quality & Others", "MPD",
"Plant Awareness", _
"Rice Cooking", "Vehicle Drivers (plant)",
"VIP", _
"15-21 & 22", "4&5 Coating", "Tank Floor 15 &
33 Bldg", "FSP's ")

Sheets(arySheets).Select

For Each sh In ActiveWorkbook.Worksheets
sh.Unprotect
Next
End If

If ActiveCell.Column = 5 And ActiveCell.Column <= 8 And
ActiveCell.Row = 3 And ActiveCell.Row <= 641 Then
UserForm1.Show
If Not IsError(res) Then

ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
Worksheets("hidden").Visible = False
Me.Select

End If

If ActiveCell < "shift " Then
Range("A" & ActiveCell.Row).Select
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst

End If
End If

End With


End Sub

Option Explicit


Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVal
Target As Range)
Dim valstr
Dim fValid As Boolean
Dim valint As Integer

On Error GoTo ws_exit:
Application.EnableEvents = False

If Not Intersect(Target, sh.Range("Skills" & sh.Index)) Is Nothing
Then

valstr = InputBox("Enter Skill Level" & vbCrLf & _
Space(5) & "1 = In Training" & vbCrLf & _
Space(5) & "2 = Trained" & vbCrLf & _
Space(5) & "3 = Can Train Others" & vbCrLf
& _
Space(5) & "4 = Delete Colour and Entry",
_
"Skills Breakdown and Competencies Entry",
"")
valint = Val(valstr)

If valint = 0 Then

Application.EnableEvents = True
sh.Protect

Exit Sub

End If

With Target
sh.Unprotect

Select Case valint
Case 1: .Interior.ColorIndex = 48
Case 2: .Interior.ColorIndex = 33
Case 3: .Interior.ColorIndex = 6
Case 4: .Interior.ColorIndex = xlNone
Value = ""

Case Else: MsgBox "Invalid Entry Try Again!"

End Select
If valint = 4 Then
With Target
sh.Cells(.Row, .Column + kTestColOff).Value = ""
End With
Else
CheckCondition Target, sh
End If
'sh.Range("A" & .Row).Select
End With


End If

ws_exit:
Application.EnableEvents = True

End Sub

Private Sub CheckCondition(ByVal Target As Range, ByVal sh As Object)

Dim rngtest As Range

With Target
Set rngtest = sh.Cells(.Row, .Column + kTestColOff)
If rngtest = "" Then
Font.ColorIndex = kColorTest1
Value = "h"

End If
rngtest.Value = ""
End With

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim lDat_Today As Date
Dim lDat_Tomorrow As Date
Dim sStr As String
Dim myattr

With ThisWorkbook
'Check ReadOnly status to establish if
'this is a backup copy
'If GetAttr(.Name) And vbReadOnly = 1 Then Exit Sub
If ActiveWorkbook.ReadOnly Then Exit Sub
lDat_Today = Date
If Format(Date, "ddd") = "Fri" Then
lDat_Tomorrow = Date + 3
Else
lDat_Tomorrow = Date + 1
End If

If Not Month(lDat_Today) = Month(lDat_Tomorrow) Then
sStr = .Path & "\" & _
Left(.Name, InStr(1, _
LCase(.Name), _
".xls") - 1) & _
" - " & Format(Now, "yyyymmdd") & ".xls"
On Error Resume Next
SaveCopyAs sStr
On Error GoTo 0
SetAttr sStr, vbReadOnly
End If
End With
End Sub


--
Simon Lloyd
------------------------------------------------------------------------
Simon Lloyd's Profile:
http://www.excelforum.com/member.php...fo&userid=6708
View this thread: http://www.excelforum.com/showthread...hreadid=266360