Remove old users to speed up shared workbook

[Chris_010101]

Hi All,

My team use a shared, macro-enabled (.xlsm) workbook, with roughly 25 users in it at the same time, 24 hours a day.

Over a few days, the shared user list gets full up, sometimes people's entries appear in there 4 or 5 times each. This causes the workbook to get bogged down which eventually results in it becoming corrupted and most of the time data loss occurrs as a system backup has to be restored through 'previous versions' in the folder properties.

My only way to fix this at the moment is to regularly ask everyone to save their work and exit the spreadhseet, so I can unshare and re-share it, which clears the list. The issue with this is when multiple users try to save at the same time, the 'file locked' message appears, so each of the 25 odd users has to keep trying to save until they've all saved which ends up being hours sometimes that the spreadsheet is out of use. Then each has to confirm via email they've saved and exited (as I have to temporarily move the spreadsheet from the shared drive to my desktop to stop it being accessed whilst I'm trying to fix it).

With users all over the globe, working at all different times, this is just a complete pain in the posterior, as you can probably imagine. Also, despite being told not to numerous times, users leave the shared excel open and then log off, disconnecting the VPN, when they've finished their shift. I'm pretty sure this doesn't help the situation.

So I did a little bit of digging, and came accross the following VBA code (from Super User) which is supposed to remove all shared users who have been in the workbook for more than X hours.

I'm using all of the below macros but can't get the bolded "SharedUserCheck" macro to work.

I click run, I get a spinning wheel and then nothing happens (entires greater than 12 hours are still there). I'm trying to run this with the workbook still shared, as this is supposed to work:

Sub Clean_Up()
    'Clean up Extra Data to prevent file from being sluggish
    Dim cv As CustomView
 
    For Each cv In ActiveWorkbook.CustomViews
        cv.Delete
    Next cv
    SharedUserCheck
End Sub
 
Sub SharedUserCheck()
    'Remove old users to speed up shared workbook
    Dim TimeStart As Date
    Dim TimeLimit As Date
    Dim SharedDuration As Date
    Dim Users As Variant
    Dim UserCount As Integer
 
    'Set time limit here in "HH:MM:SS"
    TimeLimit = TimeValue("12:00:00")
    Users = ActiveWorkbook.UserStatus
 
    For UserCount = UBound(Users) To 1 Step -1
        TimeStart = Users(UserCount, 2)
        SharedDuration = Now - TimeStart
        If SharedDuration > TimeLimit Then
            'MsgBox (Users(UserCount, 1) & " has been inactive for " & Application.Text(SharedDuration, "[hh]:mm") & " and will now be removed from the workbook.")
            ThisWorkbook.RemoveUser (UserCount)
        End If
    Next
End Sub
 
Public Sub RemoveOtherUsers()
    'Remove all other users to prevent access violation
    Dim Users As Variant
    Dim UserCount As Integer
 
    Users = ThisWorkbook.UserStatus
    For UserCount = UBound(Users) To 1 Step -1
        If Users(UserCount, 1) <> Application.UserName Then
            ThisWorkbook.RemoveUser (UserCount)
        End If
    Next
End Sub
 
Public Sub SundayMaintenance()
    Application.ScreenUpdating = False
    'On every Sunday the first time the sheet is opened clear out extra data and extra sheets
    If (WeekdayName(Weekday(Date)) = "Sunday") And (Sheets(1).Cells(3, "AG").Value < Date) Then
 
        'Disconnect other users as a precaution
        RemoveOtherUsers
 
        Application.DisplayAlerts = False
 
        'Unshare to clear extra data out    
        ThisWorkbook.UnprotectSharing ("Whatever Password")
 
        Application.DisplayAlerts = True
 
        'Set Change History to 1 day to prevent build up of junk in the file
        With ThisWorkbook
            If .KeepChangeHistory Then
                .ChangeHistoryDuration = 1
            End If
        End With
 
        'Store Last Date Unshared and Cleared to prevent multiple unshare events on sunday. 
        Sheets(1).Cells(3, "AG").Value = Date
 
        'Delete all extra sheets that were added by mistake and have the word sheet in them
        For Each WS In ThisWorkbook.Worksheets
            If UCase(WS.Name) Like "Sheet" & "*" Then
                Application.DisplayAlerts = False
                WS.Delete
                Application.DisplayAlerts = True
            End If
        Next
 
        'Reshare
        Application.DisplayAlerts = False
        ThisWorkbook.ProtectSharing Filename:=ThisWorkbook.FullName, SharingPassword:="Whatever Password"
        Application.DisplayAlerts = True
 
    End If
    Application.ScreenUpdating = True
End Sub

I've got very minimal knowledge of VBA code, so wondering if someone could provide a simple explanation, for a beginner?

I'm using Microsoft Office Standard 2016.

Kind Regards
Chris

 

[Chris_010101]

Can anyone help?