1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. 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...

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

Timer code

Discussion in 'VBA Macros' started by sms2luv, Aug 4, 2017.

  1. sms2luv

    sms2luv Member

    Messages:
    262
    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.
  2. Logit

    Logit Member

    Messages:
    90
    .
    Re: Timer ...

    Paste this macro in a Routine Module :

    Code (vb):

    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 (vb):

    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

     
    sms2luv likes this.
  3. Logit

    Logit Member

    Messages:
    90
    .
    To track changes in the workbook, paste this code into ThisWorkbook module :

    Code (vb):

    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.
    Chirag R Raval likes this.
  4. sms2luv

    sms2luv Member

    Messages:
    262
    Great thanks
  5. Logit

    Logit Member

    Messages:
    90
    You are welcome
  6. sms2luv

    sms2luv Member

    Messages:
    262
    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
  7. Logit

    Logit Member

    Messages:
    90
    Will the file get saved when it closes automatically .... YES

    Code (vb):

    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.
  8. sms2luv

    sms2luv Member

    Messages:
    262
    If a refer any shape, table, range of sheet 1 in VBA sheet 2, will that not work?
  9. Logit

    Logit Member

    Messages:
    90
  10. sms2luv

    sms2luv Member

    Messages:
    262
    I mean if I write a script to change font size in sheet 1, can I write it in Sheet 2.
  11. Logit

    Logit Member

    Messages:
    90
    What happened when you did ?
  12. sms2luv

    sms2luv Member

    Messages:
    262
    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.
  13. Logit

    Logit Member

    Messages:
    90
    Paste this in the Sheet 1 level module:

    Code (vb):

    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.
  14. sms2luv

    sms2luv Member

    Messages:
    262
    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.
  15. Logit

    Logit Member

    Messages:
    90
    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 (vb):
    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.
    sms2luv likes this.

Share This Page