Update closed workbooks & check if already open

Hi

I've entered the below code in my workbook, and it's working perfectly. However I hadn't considered that some of the files that the code opens, update and save could already be open by another user on the network.

But I can't figure out how to adjust my code so it doesn't update already opened files? And at the same time I would like a msgbox so popup and tell the user that, file XXX hasn't been updated.

Is this possible?

Private Sub Workbook_Open()

Todaysdate = Date
Worksheets("Dates").Range("C4").Value = Todaysdate

MsgBox "The report is being updated, click ok and wait", vbExclamation

    Dim MyPath          As String
    Dim MyFile          As String
    Dim Wkb             As Workbook
    Dim Cnt             As Long
    
    Application.ScreenUpdating = False
    
    MyPath = "F:\MS_DOK\........\" 
    
    If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
    
    MyFile = Dir(MyPath & "*.xlsm")
    
    Cnt = 0
    Do While Len(MyFile) > 0
        Cnt = Cnt + 1
        Set Wkb = Workbooks.Open(MyPath & MyFile)
        Wkb.Close SaveChanges:=True
        'Wkb.Worksheets("Sheet1").Range("B7").Value = "MyNewValue"
        'Wkb.Close savechanges:=True
        MyFile = Dir
    Loop
    
    If Cnt > 0 Then
        MsgBox "Updating has been completed", vbExclamation
    Else
        MsgBox "No files were found!", vbExclamation
    End If
    
    Application.ScreenUpdating = True
End Sub

I appreciate all the help I can get

Thanks

Hi there,

See if the following code does what you need:

Option Explicit


Private Sub Workbook_Open()

    Const sSHEET_NAME   As String = "Dates"
    Const sDATE_CELL    As String = "C4"
    Const sFILE_PATH    As String = "F:\MS_DOK\........\"   '   Include trailing backslash
    Const sEXTENSION    As String = ".xlsm"

    Dim iTotalNoOfFiles As Integer
    Dim iUpdatedFiles   As Integer
    Dim sFileName       As String
    Dim dteToday        As Date
    Dim sMessage        As String
    Dim wbk             As Workbook

    ThisWorkbook.Worksheets(sSHEET_NAME).Range(sDATE_CELL).Value = dteToday

    MsgBox "The report is being updated, click ok and wait", vbExclamation

    Application.ScreenUpdating = False

        sFileName = Dir(sFILE_PATH & "*" & sEXTENSION)

        iTotalNoOfFiles = 0
        iUpdatedFiles = 0

        Do While Len(sFileName) > 0

            iTotalNoOfFiles = iTotalNoOfFiles + 1

            Set wbk = Workbooks.Open(sFILE_PATH & sFileName)

'           Update only files which have not been already opened by another User
            If wbk.ReadOnly = False Then

'                 * * *   Code for updating workbook goes here   * * *

                  iUpdatedFiles = iUpdatedFiles + 1

            Else: MsgBox "The file """ & sFileName & """ is already open and " & _
                         "cannot be updated at this time", vbInformation

            End If

            wbk.Close SaveChanges:=True

            sFileName = Dir

        Loop

        If iTotalNoOfFiles > 0 Then

              sMessage = "Updating has been completed" & _
                          vbLf & vbLf & _
                          iUpdatedFiles & " file(s) has/have been updated"

              If iTotalNoOfFiles > iUpdatedFiles Then

                  sMessage = sMessage & _
                             vbLf & vbLf & _
                             iTotalNoOfFiles - iUpdatedFiles & _
                             " file(s) cannot be updated at this time"

              End If

              MsgBox sMessage, vbInformation

        Else: MsgBox "No files were found!", vbExclamation

        End If

    Application.ScreenUpdating = True

End Sub

The highlighted values may be altered to suit your own requirements.


Hope this helps - please let me know how you get on.

Regards,

Greg M

Hi Greg

It's really nice code, and it's almost working.

But when a file is open by another user, this code still opens the file, just in a "write protected" version and opens the "save as" menu. Which I have to close before your code finish.

Do you know how to avoid that?

I really appreciate the help

true adding in

Application.DisplayAlerts = False 'for the area of the code you dont want messages aka alerts

Application.DisplayAlerts = True 'for when you want to turn alerts back on

That doesn't change anything.,

I guess I need some sort of code here:

            Else: MsgBox "The file """ & sFileName & """ is already open and " & _
                         "cannot be updated at this time", vbInformation

            End If

That just closes the workbook again?

Hi again,

Sorry about that - trying to test a solution in a "simulated" environment sometimes allows glitches to pass unnoticed.

See if the following version works for you:

Option Explicit


Private Sub Workbook_Open()

    Const sSHEET_NAME   As String = "Dates"
    Const sDATE_CELL    As String = "C4"
    Const sFILE_PATH    As String = "F:\MS_DOK\........\"   '   Include trailing backslash
    Const sEXTENSION    As String = ".xlsm"

    Dim iTotalNoOfFiles As Integer
    Dim iUpdatedFiles   As Integer
    Dim sFileName       As String
    Dim dteToday        As Date
    Dim sMessage        As String
    Dim wbk             As Workbook

    ThisWorkbook.Worksheets(sSHEET_NAME).Range(sDATE_CELL).Value = dteToday

    MsgBox "The report is being updated, click ok and wait", vbExclamation

    Application.ScreenUpdating = False

        sFileName = Dir(sFILE_PATH & "*" & sEXTENSION)

        iTotalNoOfFiles = 0
        iUpdatedFiles = 0

        Do While Len(sFileName) > 0

            iTotalNoOfFiles = iTotalNoOfFiles + 1

            Set wbk = Workbooks.Open(sFILE_PATH & sFileName)

'           Update only files which have not been already opened by another User
            If wbk.ReadOnly = False Then

'                 * * *   Code for updating workbook goes here   * * *

                  iUpdatedFiles = iUpdatedFiles + 1

                  wbk.Close SaveChanges:=True

            Else: wbk.Close SaveChanges:=False

                  MsgBox "The file """ & sFileName & """ is already open and " & _
                         "cannot be updated at this time", vbInformation

            End If

            sFileName = Dir

        Loop

        If iTotalNoOfFiles > 0 Then

              sMessage = "Updating has been completed" & _
                          vbLf & vbLf & _
                          iUpdatedFiles & " file(s) has/have been updated"

              If iTotalNoOfFiles > iUpdatedFiles Then

                  sMessage = sMessage & _
                             vbLf & vbLf & _
                             iTotalNoOfFiles - iUpdatedFiles & _
                             " file(s) cannot be updated at this time"

              End If

              MsgBox sMessage, vbInformation

        Else: MsgBox "No files were found!", vbExclamation

        End If

    Application.ScreenUpdating = True

End Sub

Hope this helps - as before, please let me know how you get on.

Regards,

Greg M

Hi again,

If the above proposal works for you, it might be more efficient to store the names of the already opened workbooks and display them in a single list at the end of the process rather than continually interrupting the process with individual messages.

I can implement this for you if you wish.

Regards,

Greg M

Hi Greg

This works perfectly!!!! Just what I wanted... Thanks alot..

Sure if possible it wouldn't hurt to have a single list at the end, so if you have time, I would like that.

Hi again,

Many thanks for your feedback and also for the Reputation increase - much appreciated!

Your wish is my command!

See if the following code does what you need:

Option Explicit


Private Sub Workbook_Open()

    Const sSHEET_NAME   As String = "Dates"
    Const sDATE_CELL    As String = "C4"
    Const sFILE_PATH    As String = "F:\MS_DOK\........\"   '   Include trailing backslash
    Const sEXTENSION    As String = ".xlsm"

    Dim iTotalNoOfFiles As Integer
    Dim sOpenFileNames  As String
    Dim iUpdatedFiles   As Integer
    Dim sFileName       As String
    Dim dteToday        As Date
    Dim sMessage        As String
    Dim wbk             As Workbook

    ThisWorkbook.Worksheets(sSHEET_NAME).Range(sDATE_CELL).Value = dteToday

    MsgBox "The report is being updated, click ok and wait", vbExclamation

    Application.ScreenUpdating = False

        sFileName = Dir(sFILE_PATH & "*" & sEXTENSION)

        sOpenFileNames = vbNullString
        iTotalNoOfFiles = 0
        iUpdatedFiles = 0

        Do While Len(sFileName) > 0

            iTotalNoOfFiles = iTotalNoOfFiles + 1

            Set wbk = Workbooks.Open(sFILE_PATH & sFileName)

'           Update only files which have not been already opened by another User
            If wbk.ReadOnly = False Then

'                 * * *   Code for updating workbook goes here   * * *

                  iUpdatedFiles = iUpdatedFiles + 1

                  wbk.Close SaveChanges:=True

            Else: wbk.Close SaveChanges:=False

                  sOpenFileNames = sOpenFileNames & vbLf & vbTab & sFileName

            End If

            sFileName = Dir

        Loop

        If iTotalNoOfFiles > 0 Then

              sMessage = "Updating has been completed" & _
                          vbLf & vbLf & _
                          iUpdatedFiles & " file(s) has/have been updated"

              If sOpenFileNames <> vbNullString Then

                  sMessage = sMessage & _
                             vbLf & vbLf & _
                             "The following files were already open and could not " & _
                             "be updated at this time:" & sOpenFileNames

              End If

              MsgBox sMessage, vbInformation

        Else: MsgBox "No files were found!", vbExclamation

        End If

    Application.ScreenUpdating = True

End Sub

As before, please let me know how you get on.

Regards,

Greg M

Hi Greg

yet again you've done it!

It works perfectly

Thank you so much for your help.

Hi again,

Many thanks for your feedback - I'm very pleased that I was able to help.

Best regards,

Greg M