If File is Readonly. MsgBox then Exit Sub.

[Xlacs]

Hi Good People.

I have a simple problem yet I cant manage to solve it.
Hoping someone here can actually help me on this one.

Basically,

I have 2 excel workbook. data source and masterfile.
Datasource is using by multiple user to submit data to the masterfile.
I need to put a restriction on this if they simultaneously submit data to the masterfile.


If the masterfile is open to another user, an error msgbox will appear that the file is in readonly.

My below code does not work.. =(

Sub Submit()
    Const WB_ARCH_PATH As String = "C:\Users\ChrisLacs\Desktop\Test\"
    Const WB_ARCH_NM As String = "Archive.xlsm"
    
    Dim wsSrc As Worksheet, r As Long, rw As Range, wbArch As Workbook
    Dim wsArch As Worksheet, cDest As Range
    
    Set wsSrc = ThisWorkbook.Sheets("Prod")  'source data sheet
    
   
    
    Set wbArch = Workbooks(WB_ARCH_NM)
   
    If Workbooks("Archive.xlsm").ReadOnly Then
     MsgBox "This workbook is already opened by another user."
     Exit Sub
     
     End If
     
    If wbArch Is Nothing Then Set wbArch = Workbooks.Open(WB_ARCH_PATH & WB_ARCH_NM)
    Set wsArch = wbArch.Worksheets("Master")
    Set cDest = wsArch.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) 'first paste destination
    
    For r = 2 To wsSrc.Cells(Rows.Count, "B").End(xlUp).Row   'loop source rows
        Set rw = wsSrc.Rows(r)
        If rw.Columns("O").Value <> "Submitted" And rw.Columns("J").Value = "Pending" Or rw.Columns("J").Value = "Funded" Then
        
            rw.Cells(2).Resize(1, 9).Copy cDest  'Copy A:C for row `rw`
            rw.Columns("O").Value = "Submitted"  'update to Submitted
            Set cDest = cDest.Offset(1, 0)       'next paste destination
        End If
    Next r
    
    wbArch.Close True 'save changes
    
End Sub

 

[Siddharth Rout]

Try this.

Option Explicit

Sub Sample()
    Dim Ret

    '~~> Change this to the relevant file
    Ret = IsWorkBookOpen("C:\myWork.xlsx")

    If Ret = True Then
        MsgBox "File is open"
    Else
        MsgBox "File is Closed"
    End If
End Sub

Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long

    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0

    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function

 

[Xlacs]

Try this.

Option Explicit

Sub Sample()
    Dim Ret

    '~~> Change this to the relevant file
    Ret = IsWorkBookOpen("C:\myWork.xlsx")

    If Ret = True Then
        MsgBox "File is open"
    Else
        MsgBox "File is Closed"
    End If
End Sub

Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long

    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0

    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function

Hi Siddharth!

Thanks for the quick response.​

Do you mind combining it to my codes?
Im afraid this would cause me trouble. =/

 

[Siddharth Rout]

ub Sample() Dim Ret Ret = IsWorkBookOpen("C:\myWork.xlsx") If Ret = True Then MsgBox "File is open" Els

Umm, something like this (UNTESTED)

Option Explicit

Sub Submit()
    Const WB_ARCH_PATH As String = "C:\Users\ChrisLacs\Desktop\Test\"
    Const WB_ARCH_NM As String = "Archive.xlsm"
    
    Dim DbFile As String
    DbFile = WB_ARCH_PATH & WB_ARCH_NM
    
    Dim wsSrc As Worksheet
    Set wsSrc = ThisWorkbook.Sheets("Prod")  'source data sheet
    
    Dim Ret
    Ret = IsWorkBookOpen(DbFile)
    
    If Ret = True Then
        MsgBox "This workbook is already opened by another user."
        Exit Sub
    End If
    
    Dim wbArch As Workbook
    Dim r As Long, rw As Range
    Dim wsArch As Worksheet, cDest As Range
    
    Set wbArch = Workbooks.Open(DbFile)
    Set wsArch = wbArch.Worksheets("Master")
    Set cDest = wsArch.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) 'first paste destination
    
    For r = 2 To wsSrc.Cells(Rows.Count, "B").End(xlUp).Row   'loop source rows
        Set rw = wsSrc.Rows(r)
        If rw.Columns("O").Value <> "Submitted" And rw.Columns("J").Value = "Pending" Or rw.Columns("J").Value = "Funded" Then
        
            rw.Cells(2).Resize(1, 9).Copy cDest  'Copy A:C for row `rw`
            rw.Columns("O").Value = "Submitted"  'update to Submitted
            Set cDest = cDest.Offset(1, 0)       'next paste destination
        End If
    Next r
    
    wbArch.Close True 'save changes
End Sub

Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long

    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0

    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function

 

[Xlacs]

Ok. Im having trouble with the above codes.
aha.

Thanks anyway.. =)

 

[Siddharth Rout]

Ok. Im having trouble with the above codes.
aha.

Thanks anyway.. =)

What trouble?

 

[Xlacs]

the readonly is working.. but when I closed the masterfile. The data is not submitting.

 

[Xlacs]

Nevermind.. Its working! Awesome.. Thank youuu!!!