• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Timer code

S

sms2luv

Member
I have a file, which is on shared drive.
Many people access the file, however forget to close it. Due to which others have to open in read only mode.
1st requirements.

I want a code that will make a pop up after 30 min that will shoe that the file will be closed automatically without saving any changes.

2nd requirements.

Whenever any changes are done in the file, a file should contain all Information about the changes.
 
.
Re: Timer ...

Paste this macro in a Routine Module :

Code: 
Option Explicit

Dim DownTime As Date

Sub SetTimer()
    DownTime = Now + TimeValue("00:30:00")  ''<--- change time to close here
    Application.OnTime EarliestTime:=DownTime, Procedure:="ShutDown", Schedule:=True
End Sub
Sub StopTimer()
    On Error Resume Next
    Application.OnTime EarliestTime:=DownTime, _
      Procedure:="ShutDown", Schedule:=False
 End Sub
Sub ShutDown()

    Application.DisplayAlerts = False
    With ThisWorkbook
        .Saved = True
        .Close
    End With
   
End Sub


Paste this into ThisWorkbook Module :

Code: 
Option Explicit

Private Sub Workbook_Open()
    Call SetTimer
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call StopTimer
    Application.DisplayAlerts = False
    ThisWorkbook.Saved = True
    Application.Visible = False
    Application.Quit
End Sub
 
.
To track changes in the workbook, paste this code into ThisWorkbook module :

Code: 
Option Explicit
Dim vOldVal 'Must be at top of module

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim strUserName As String
Dim xFormula As Boolean
Dim xDate As Boolean
Dim xHead As Range
Dim xTitle As Range
Dim n As Integer

Set xHead = Sheets("Track_Changes").Range("B3:H3")
strUserName = Application.UserName

On Error Resume Next
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]"
    xFormula = Target.HasFormula
    xDate = IsDate(Target)

    With Sheets("Track_Changes")
        .Unprotect Password:="Password"
    
                If .Range("B2") = vbNullString Then
                    xHead = Array("DATE OF CHANGE", "TIME OF CHANGE", "SHEET NAME", "CELL CHANGED", "CHANGE BY", "OLD VALUE", "NEW VALUE")
                Sheets("Track_Changes").Columns(1).ColumnWidth = 3
              
                .Range("B1").Value = "Track Changes"
                .Range("B1").Font.Size = 18
                              
                With xHead
                    .Interior.Color = RGB(30, 139, 195)
                    .Font.Color = vbWhite
                    .Font.Bold = True
                End With

                With xHead.Borders(xlInsideVertical)
                    .Color = vbWhite
                    .Weight = xlMedium
                End With
                End If
          
      
        With .Cells(.Rows.Count, 2).End(xlUp)(2, 1)
                    .Borders(xlInsideVertical).Color = RGB(255, 191, 191)
                    .Borders(xlInsideVertical).Weight = xlMedium
                  
                    .Value = Date
                    .Offset(0, 1) = Format(Now, "hh:mm:ss")
                    .Offset(0, 2) = Target.Parent.Name
                    .Offset(0, 3) = Target.Address
                    .Offset(0, 4) = strUserName
                    .Offset(0, 5) = vOldVal
                
                    With .Offset(0, 6)
                        If xFormula = True Then
                            .ClearComments
                            .AddComment.Text Text:="Cell is bold as value contains a formula"
                        End If
                        If xDate = True Then
                            .NumberFormat = "dd/mm/yyyy"
                        End If
                        .Value = Target
                        .Font.Bold = xFormula
                        If IsEmpty(Target) Then .Value = "[empty cell]"
                    End With
                  
            End With

            .Cells.Columns.AutoFit
            .Cells.Columns.HorizontalAlignment = xlLeft
          
n = Sheets("Track_Changes").Range("B:B").Cells.SpecialCells(xlCellTypeConstants).Count - 1
With Sheets("Track_Changes").Range("B4:H" & n + 2)
        .Borders(xlInsideHorizontal).Color = RGB(30, 139, 195)
        .Borders(xlInsideHorizontal).Weight = xlThin
        .Borders(xlInsideVertical).Color = RGB(200, 200, 200)
        .Borders(xlInsideVertical).Weight = xlThin
End With
.Protect Password:="Password"
        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)

On Error Resume Next
If Selection.Cells.Count > 1 Then Exit Sub 'Avoid runtime error 7
    vOldVal = Target

End Sub

You will need a separate worksheet called Track_Changes .

In B1 type TRACK CHANGES

In B3 to H3 enter:

DATE OF CHANGE
TIME OF CHANGE
SHEET NAME
CELL CHANGED
CHANGE BY
OLD VALUE
NEW VALUE

When changes are made to the file, the edits will be noted beginning on B4. The next change will be noted on B5, etc.
 
Had a quick question
Will the file get saved when it closes automatically.
Can we manually save the file.
Can I protect the file from getting Renamed or deleted.
What's the difference between Routine module and This sheet module
 
Will the file get saved when it closes automatically .... YES

Code: 
PrivateSub Workbook_BeforeClose(Cancel AsBoolean)
  Call StopTimer
    Application.DisplayAlerts = False
    ThisWorkbook.Saved = True
    Application.Visible = False
    Application.Quit
EndSub

Can we manually save the file ... YES

Can I protect the file from getting Renamed or deleted ... YES
http://datapigtechnologies.com/blog/index.php/prevent-worksheet-delete-without-workbook-protection/


What's the difference between Routine module and This sheet module

Routine Module code applies to any sheet / Sheet Module applies to only that sheet.
 
What I want to do example : Change cell color.
Where : Sheet1 A11.
In VBA we can see all sheets like ( sheet1, 2, 3 )and thisworksheet.
So if I write the above code in Sheet2, will it work for excel sheet 1.

Hope its clear now.
 
Paste this in the Sheet 1 level module:

Code: 
Option Explicit
Sub cng()
Sheets("Sheet2").Range("A1").Interior.Color = vbRed
End Sub

Place a Command Button on any sheet you want and connect it to the above macro.
 
Alright, I think you did not get my question.
I mean to say that all codes related to Sheet1 sheet should be pasted in VBA module, this workbook and Sheet1.
If we put any code related to sheet 1 in Sheet2 Vba editor, will if still run.
 
I've never tried to do what you are asking. I always use either a Routine Module or the Sheet Module.

However, the code I gave you :

Code: 
Option Explicit
Sub cng()
Sheets("Sheet2").Range("A1").Interior.Color = vbRed
End Sub

Proves that at least some code runs from another sheet module.

Consider that doing so is not standard. Makes things harder to track down (errors, etc) if the code is placed in unusual locations.
 
Need small help here.
Can we set a floating Timer in the sheet to know the remaining time to close the wookbook.
Also when 30 seconds are left, can we get some notification.
 
You must log in or register to reply here.
Back
Top