Excel VBA to refresh document open for read-only

Question

Is it possible to refresh a document open for read-only such that if someone else has it open for write it displays whatever updates have been made since the last refresh but doesn't stray from the active worksheet?

I have accomplished the former, but when it re-opens it goes to whatever worksheet was opened before the last save.

Sub refresh()
    Application.DisplayAlerts = False
    Workbooks.Open Filename:=ActiveWorkbook.Path & "\" & "name.xls", ReadOnly:=True
End Sub

Thanks

Answer 1

This code goes into two Workbooks

1. It uses the SheetActivate Event to continuosly write a log of the current sheet of your main file (name.xls in your example above) to a log.txt file
2. A "controller" workbook is used to:
   • test whether the main file is open,
   • if it is then a readonly version is opened (if not the actual file is opened normally), and
   • the file log (which stores last sheet, windows logon name & current time progressively - perhaps overkill) is accessed to set the most recent worksheet.

Note:
1. I could only test this on my local machine by running two separate instances of Excel on my main file as Excel won't let the same file be open twice in the same instance)
2. Rather than a controller workbook I would advise using a vbscript executed from a desktop shortcut

Change this line to set the file path and name to test for being open
StrFileName = "c:\temp\main.xlsm"

Code for document to be opened: ThisWorkbook module

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Open ThisWorkbook.Path & "\log.txt" For Append As #1
    Print #1, Sh.Name & ";" & Environ("username") & ":" & Format(Now(), "dd-mmm-yy hh:mm")
    Close #1
End Sub

Code for Controller workbook: Normal module

I have updated the microsoft website code to test if StrFileName is already open. If it is open elsehwere then a read-only version is opened to the most current page

Sub TestFileOpened()
    Dim Wb As Workbook
    Dim StrFileName As String
    Dim objFSO As Object
    Dim objTF As Object
    Dim strLogTxt As String
    Dim arrStr

    StrFileName = "c:\temp\main.xlsm"
    If Dir(StrFileName) = vbNullString Then
        MsgBox StrFileName & " does not exist", vbCritical
        Exit Sub
    End If
    If IsFileOpen(StrFileName) Then
        Set Wb = Workbooks.Open(StrFileName, , True)
        If Dir(Wb.Path & "\log.txt") <> vbNullString Then
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            Set objTF = objFSO.OpenTextFile(Wb.Path & "\log.txt", 1)
            Do Until objTF.AtEndOfStream
                strLogTxt = objTF.ReadLine
            Loop
            objTF.Close
            arrStr = Split(strLogTxt, ";")
            On Error Resume Next
            If Not IsEmpty(arrStr) Then
                Wb.Sheets(arrStr(0)).Activate
                If Err.Number <> 0 Then MsgBox arrStr(0) & " could not be activate"
            End If
            On Error GoTo 0
        End If
    Else
        Set Wb = Workbooks.Open(StrFileName)
    End If
End Sub

' This function checks to see if a file is open or not. If the file is
' already open, it returns True. If the file is not open, it returns
' False. Otherwise, a run-time error occurs because there is
' some other problem accessing the file.

Function IsFileOpen(filename As String)
    Dim filenum As Integer, errnum As Integer
    On Error Resume Next   ' Turn error checking off.
    filenum = FreeFile()   ' Get a free file number.
    ' Attempt to open the file and lock it.
    Open filename For Input Lock Read As #filenum
    Close filenum          ' Close the file.
    errnum = Err           ' Save the error number that occurred.
    On Error GoTo 0        ' Turn error checking back on.
    ' Check to see which error occurred.
    Select Case errnum
        ' No error occurred.
        ' File is NOT already open by another user.
    Case 0
        IsFileOpen = False
        ' Error number for "Permission Denied."
        ' File is already opened by another user.
    Case 70
        IsFileOpen = True
        ' Another error occurred.
    Case Else
        Error errnum
    End Select
End Function