CODEWITHSUNDEEP
vbaexcel
user7415328
user7415328

Reputation: 1083

VBA Auto Save workbook every 10 seconds without activating workbook?

I am using the following vba code in a workbook open event:

Private Sub Workbook_Open()
On Error GoTo Message

Application.AskToUpdateLinks = False
ThisWorkbook.UpdateLinks = xlUpdateLinksNever
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False



    Dim currentTime As Date
    currentTime = DateAdd("s", 10, Now)
    Call CurUserNames
    Application.OnTime currentTime, "SaveFile"

Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub

End Sub

I also have this code in a module:

Public Sub SaveFile()

On Error GoTo Message


    ThisWorkbook.Save

    Dim currentTime As Date
    currentTime = DateAdd("s", 10, Now)

    Application.OnTime currentTime, "SaveFile"

    Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub

End Sub

What I am trying to do is automatically save my workbook every 10 seconds.

This works.

However, something quite annoying I've noticed happens. If a user has this workbook open in the background and is working on another excel workbook then this workbook will activate and display on top of the other workbook when saving.

This can be quite annoying for the user. Is there a way I can get my workbook to save without activating the workbook?

P.S: For some unknown reason, this also causes the workbook to reopen when its been closed.

EDIT:

List active users in workbook code:

Sub CurUserNames()

Dim str As String
Dim Val1 As String

str = "Users currently online:" & Chr(10)

For i = 1 To UBound(ThisWorkbook.UserStatus)
     str = str & ThisWorkbook.UserStatus(i, 1) & ", "
Next

Val1 = DeDupeString(Mid(str, 1, Len(str) - 2))


Worksheets("Delivery Tracking").Range("F4").Value = Val1


End Sub


Function DeDupeString(ByVal sInput As String, Optional ByVal sDelimiter As String = ",") As String

    Dim varSection As Variant
    Dim sTemp As String

    For Each varSection In Split(sInput, sDelimiter)
        If InStr(1, sDelimiter & sTemp & sDelimiter, sDelimiter & varSection & sDelimiter, vbTextCompare) = 0 Then
            sTemp = sTemp & sDelimiter & varSection
        End If
    Next varSection

    DeDupeString = Mid(sTemp, Len(sDelimiter) + 1)

End Function

Upvotes: 0

Views: 10991

Answers (2)

EEM
EEM

Reputation: 6659

Users of a shared workbook can see Who has this workbook open now: just by going to the Review tab in the Ribbon and click the Shared Workbook icon in the Changes group. This will open the Shared Workbook dialog box, in it the tab Editing' shows *Who has this workbook open now:`*. Additionally the tab 'Advance' can be used to update the settings dealing with:

  • Track changes
  • Update changes
  • Conflicting changes between users
  • Include in personal view

enter image description here

Upvotes: 1

John Muggins
John Muggins

Reputation: 1198

Th9is example comes from How can I get list of users using specific shared workbook?

It is a little overkill. It creates a new workbook to put the users name in. But you can modify it to put the names in whatever sheet and whatever cells you want.

Put it in the sheet module under the selection change module. Then it will update every time the user moves to a different cell. If it is open and he's not at his desk - it doesn't do anything.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

At the bottom is the code from the above link that you can modify to suit your own needs. It will be 1000 times better than saving a workbook every ten seconds. Which can actually take 3 or 4 seconds itself.

If you don't want to use selection change in the worksheet module then you could put your code into the workbook module Private Sub Workbook_Open() and put it on a timer to run every 10 seconds. It will only take a fraction of a second instead of several seconds.

users = ActiveWorkbook.UserStatus
With Workbooks.Add.Sheets(1)
    For row = 1 To UBound(users, 1)
        .Cells(row, 1) = users(row, 1)
        .Cells(row, 2) = users(row, 2)
        Select Case users(row, 3)
            Case 1
                .Cells(row, 3).Value = "Exclusive"
            Case 2
                .Cells(row, 3).Value = "Shared"
        End Select
    Next
End With

Upvotes: 0

Related Questions