Remove old users to speed up shared workbook

Rob_010101

Board Regular
Joined
Jul 24, 2017
Messages
198
Office Version
  1. 365
Platform
  1. Windows
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:

VBA Code:
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
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.

Forum statistics

Threads
1,223,888
Messages
6,175,207
Members
452,618
Latest member
Tam84

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top