VBA Help: If workbook is open return an error with option to retry

[K1600]

Hi,

I have two workbooks, WB1 & WB2 as an example. WB1 contains my UserForm and WB2 contains the master data where the entered information from the UserForm is placed.

My issue is that multiple people need to submit data via the UserForm yet if the 'Submit' button is pressed by two or more people at the same time then obviously only one can access WB2 and the other receives an error to the effect that 'a workbook with that name already exists'. I am looking for a way for my code on the 'Submit' button to check if WB2 is already open prior to continuing and if it is, then to pause the process and offer a 'Retry' button which would then continue with the 'Submit' process. I have made WB1 read only so that can now be opened by as many people as necessary but I can't fathom what to do with the check of WB2.

My code for the 'Submit' function is below however I am very new to this and it has been gleamed from reading various forum posts so please feel free to suggest other options. I haven't completely lost the plot but I have had to remove a few bits of the code as they contain identifiable info so I have replaced this with XXXX hence there are a few blocks of these throughout the code.

Thanks in advance.

Private Sub cmdTest_Click()  'Test command button
 
Cancel = 0
[COLOR=#008000]'Checks for empty fields in UserForm (except Remarks)[/COLOR]
If [COLOR=#0000ff][B]XXXX[/B][/COLOR] = "" Then
    Cancel = 1
    [B]XXXX[/B].SetFocus
ElseIf DDTxtDate.Text = "" Then
    Cancel = 1
    DDTxtDate.SetFocus
ElseIf DDcboTime1.Text = "" Then
    Cancel = 1
    DDcboTime1.SetFocus
ElseIf DDcboTime2.Text = "" Then
    Cancel = 1
    DDcboTime2.SetFocus
ElseIf DDcbo[B]XXXX[/B].Text = "" Then
    Cancel = 1
    DDcbo[B]XXXX[/B].SetFocus
ElseIf DDcbo[B]XXXX[/B].Text = "" Then
    Cancel = 1
    DDcbo[B]XXXX[/B].SetFocus
ElseIf DDTxtAge.Text = "" Then
    Cancel = 1
    DDTxtAge.SetFocus
ElseIf DDcboGender = "" Then
    Cancel = 1
    DDcboGender.SetFocus
ElseIf DDcboActions = "" Then
    Cancel = 1
    DDcboActions.SetFocus
End If
 
If Cancel = 1 Then
    MsgBox "Not All Values Have Been Entered", vbCritical, "[B]XXXX[/B] "
    Exit Sub
End If
 
 
[COLOR=#008000]'Move data from UserForm to worksheet[/COLOR]
 
Dim rw As Long 'Gets next available row
 
Dim wbk As Workbook
 
Set wbk = Workbooks.Open("\\[B]XXXX[/B].xlsx", Password:="[B]XXXX[/B] ")
With wbk.Sheets("[B]XXXX[/B] Returns") 'Selects sheet
 
rw = .Range("A" & Rows.Count).End(xlUp).Row + 1 'Gets next available row in sheet
 
[COLOR=#008000]'Put the UserForm entries in the found blank row[/COLOR]
    .Range("A" & rw).Value = DD[B]XXXX[/B].Value
    .Range("B" & rw).Value = DD[B]XXXX[/B].Value
    .Range("C" & rw).Value = DD[B]XXXX[/B].Value
    .Range("D" & rw).Value = DDTxtDate.Value
    .Range("E" & rw).Value = DDcboTime1.Value & ":" & DDcboTime2.Value  [COLOR=#008000]'Concatenates the two time entry fields[/COLOR]
    .Range("F" & rw).Value = DDTxtAge.Value
    .Range("G" & rw).Value = DDcboGender.Value
    .Range("H" & rw).Value = DDcbo[B]XXXX[/B].Value
    .Range("I" & rw).Value = DDcbo[B]XXXX[/B].Value
    .Range("J" & rw).Value = DDcboActions.Value
    .Range("K" & rw).Value = DDTxtRemarks.Value
    .Range("L" & rw).Value = Date + Time 'Adds a date/time stamp for the entry
 
[COLOR=#008000]'Puts border round selection[/COLOR]
    .Range("A" & rw).Borders.LineStyle = xlContinuous
    .Range("B" & rw).Borders.LineStyle = xlContinuous
    .Range("C" & rw).Borders.LineStyle = xlContinuous
    .Range("D" & rw).Borders.LineStyle = xlContinuous
    .Range("E" & rw).Borders.LineStyle = xlContinuous
    .Range("F" & rw).Borders.LineStyle = xlContinuous
    .Range("G" & rw).Borders.LineStyle = xlContinuous
    .Range("H" & rw).Borders.LineStyle = xlContinuous
    .Range("I" & rw).Borders.LineStyle = xlContinuous
    .Range("J" & rw).Borders.LineStyle = xlContinuous
    .Range("K" & rw).Borders.LineStyle = xlContinuous
    .Range("L" & rw).Borders.LineStyle = xlContinuous
 
[COLOR=#008000]'Closes Master Data workbook[/COLOR]
wbk.Save
wbk.Close
 
[COLOR=#008000]'Clear UserForm entries[/COLOR]
    DD[B]XXXX[/B].Value = ""
    DD[B]XXXX[/B].Value = ""
    DD[B]XXXX[/B].Value = ""
    DDTxtDate.Value = ""
    DDcboTime1.Value = ""
    DDcboTime2.Value = ""
    DDcbo[B]XXXX[/B].Value = ""
    DDcbo[B]XXXX[/B].Value = ""
    DDTxtAge.Value = ""
    DDcboGender.Value = ""
    DDcboActions.Value = ""
    DDTxtRemarks.Value = ""
 
MsgBox "Your entry has been submitted.", , "[B]XXXX[/B]"
 
ThisWorkbook.Saved = True    [COLOR=#008000]'Stops the "Do you want to save the changes" box[/COLOR]
Application.Quit
 
End With
 
End Sub

 

[dmt32]

Hi,
try this update to your code & see if does what you want:

Private Sub cmdTest_Click()  'Test command button
 
Cancel = 0
'Checks for empty fields in UserForm (except Remarks)
If XXXX = "" Then
    Cancel = 1
    XXXX.SetFocus
ElseIf DDTxtDate.Text = "" Then
    Cancel = 1
    DDTxtDate.SetFocus
ElseIf DDcboTime1.Text = "" Then
    Cancel = 1
    DDcboTime1.SetFocus
ElseIf DDcboTime2.Text = "" Then
    Cancel = 1
    DDcboTime2.SetFocus
ElseIf DDcboXXXX.Text = "" Then
    Cancel = 1
    DDcboXXXX.SetFocus
ElseIf DDcboXXXX.Text = "" Then
    Cancel = 1
    DDcboXXXX.SetFocus
ElseIf DDTxtAge.Text = "" Then
    Cancel = 1
    DDTxtAge.SetFocus
ElseIf DDcboGender = "" Then
    Cancel = 1
    DDcboGender.SetFocus
ElseIf DDcboActions = "" Then
    Cancel = 1
    DDcboActions.SetFocus
End If
 
If Cancel = 1 Then
    MsgBox "Not All Values Have Been Entered", vbCritical, "XXXX "
    Exit Sub
End If
 
 
'Move data from UserForm to worksheet
 
Dim rw As Long 'Gets next available row
Dim wbk As Workbook
 
Dim Response As VbMsgBoxResult
Dim FullFileName As String
    
    FullFileName = "\\XXXX.xlsx"
    
    If Dir(FullFileName, vbDirectory) <> vbNullString Then
        Do
            If FileInUse(FullFileName) Then
                Response = MsgBox("Database in use." & Chr(10) & _
                "Do You Want To Retry?", 37, "File In Use")
'cancel pressed
                If Response = 2 Then Exit Sub
            Else
                Exit Do
            End If
        Loop
    Else
        MsgBox FullFileName & Chr(10) & "FileName \ Path Not Found", 48, "Not Found"
        Exit Sub
    End If
 
Set wbk = Workbooks.Open(FullFileName, Password:="XXXX ")
With wbk.Sheets("XXXX Returns") 'Selects sheet
 
rw = .Range("A" & Rows.Count).End(xlUp).Row + 1 'Gets next available row in sheet
 
'Put the UserForm entries in the found blank row
    .Range("A" & rw).Value = DDXXXX.Value
    .Range("B" & rw).Value = DDXXXX.Value
    .Range("C" & rw).Value = DDXXXX.Value
    .Range("D" & rw).Value = DDTxtDate.Value
    .Range("E" & rw).Value = DDcboTime1.Value & ":" & DDcboTime2.Value  'Concatenates the two time entry fields
    .Range("F" & rw).Value = DDTxtAge.Value
    .Range("G" & rw).Value = DDcboGender.Value
    .Range("H" & rw).Value = DDcboXXXX.Value
    .Range("I" & rw).Value = DDcboXXXX.Value
    .Range("J" & rw).Value = DDcboActions.Value
    .Range("K" & rw).Value = DDTxtRemarks.Value
    .Range("L" & rw).Value = Date + Time 'Adds a date/time stamp for the entry
 
'Puts border round selection
    .Range("A" & rw).Borders.LineStyle = xlContinuous
    .Range("B" & rw).Borders.LineStyle = xlContinuous
    .Range("C" & rw).Borders.LineStyle = xlContinuous
    .Range("D" & rw).Borders.LineStyle = xlContinuous
    .Range("E" & rw).Borders.LineStyle = xlContinuous
    .Range("F" & rw).Borders.LineStyle = xlContinuous
    .Range("G" & rw).Borders.LineStyle = xlContinuous
    .Range("H" & rw).Borders.LineStyle = xlContinuous
    .Range("I" & rw).Borders.LineStyle = xlContinuous
    .Range("J" & rw).Borders.LineStyle = xlContinuous
    .Range("K" & rw).Borders.LineStyle = xlContinuous
    .Range("L" & rw).Borders.LineStyle = xlContinuous
 
'Closes Master Data workbook
wbk.Save
wbk.Close
 
'Clear UserForm entries
    DDXXXX.Value = ""
    DDXXXX.Value = ""
    DDXXXX.Value = ""
    DDTxtDate.Value = ""
    DDcboTime1.Value = ""
    DDcboTime2.Value = ""
    DDcboXXXX.Value = ""
    DDcboXXXX.Value = ""
    DDTxtAge.Value = ""
    DDcboGender.Value = ""
    DDcboActions.Value = ""
    DDTxtRemarks.Value = ""
 
MsgBox "Your entry has been submitted.", , "XXXX"
 
ThisWorkbook.Saved = True    'Stops the "Do you want to save the changes" box
Application.Quit
 
End With
 
End Sub

Add following function to a STANDARD module

Function FileInUse(ByVal FileName As String) As Boolean
    On Error Resume Next
    Open FileName For Binary Access Read Lock Read As #1 
    Close #1 
    FileInUse = CBool(Err.Number > 0)
    On Error GoTo 0
End Function

Hope Helpful

Dave

 

[K1600]

Cheers Dave, you are a star!!

I have another couple of bits that are niggling me if you or anyone could possibly assist.

1. I have set WB1 to open straight to the UserForm using the following code however, after it's opened, even though the cursor is flashing in the correct field of the UserForm, the window isn't active and I need to click onto the window before I can enter. Is there a way around this?

Private Sub Workbook_Open()
    Application.WindowState = xlMinimized 'user cannot see what is entered in Excel
    UserForm.Show
End Sub

2. When data is entered into the first field in my UserForm I've used the 'AfterUpdate' function to call WB2 and run a vlookup to auto fill two other fields. When it calls it, WB2 can be seen to open and then close again in the main window. Is there a way to make it run in the background and not show WB2. It is only momentarily as it gets the info but it looks messy.

Private Sub DDXXXX_AfterUpdate()


Dim wbk As Workbook
Set wbk = Workbooks.Open("\\XXXX.xlsx", ReadOnly:=True)


'Check to see if XXXX exists
If WorksheetFunction.CountIf(wbk.Sheets("Authorised Users").Range("A:A"), Me.XXXX.Value) = 0 Then
    MsgBox "Incorrect XXXX Entered", vbCritical, "XXXX"
    Me.DDXXXX.Value = ""
Exit Sub
End If


'Lookup values based on first control
With Me
'Checks data range for XXXX. "Lookup" is the named range in the XXXX sheet
.DDXXXX = Application.WorksheetFunction.VLookup(CLng(Me.DDXXXX), wbk.Sheets("Authorised Users").Range("Lookup"), 3, 0)
.DDXXXX = Application.WorksheetFunction.VLookup(CLng(Me.DDXXXX), wbk.Sheets("Authorised Users").Range("Lookup"), 4, 0)


End With
wbk.Close savechanges:=False


End Sub

Thanks again,

Glynn

 

[dmt32]

hi,
1 - try

Private Sub Workbook_Open()
    Load UserForm1
    Application.Visible = False
    UserForm1.Show
End Sub

set Visible property to True when you close the Form if required or when you close the application.


2-

Application.ScreenUpdating = False
Set wbk = Workbooks.Open("\\XXXX.xlsx", ReadOnly:=True)




' your code




Application.ScreenUpdating = True

you should have mentioned that you had asked Q1 here:https://www.mrexcel.com/forum/excel-questions/1028797-vba-change-userform.html

Dave

 

[K1600]

Cheers Dave,

Number 2 has worked great, number 1 is far better as the Excel window doesn't appear at all but I still have to click into the window for some reason to activate it.

With regards my other post at:https://www.mrexcel.com/forum/excel-...-userform.html this was a different query so I thought I would need to post it separately. What I was trying to achieve with that was to be bale to use a bit of VBA to basically by sing a command button in another WB to load a different UserForm to WB1 which would basically say that it was under maintenance and to come back later. My apologies if I didn't post correctly.

Thanks again,
Glynn

 

[dmt32]

Hi,
glad suggestions have helped

nothing wrong posting a new question but you also asked the same question in thread I was responding & where I gave a suggestion - Its just others won't know this if they take the time to respond to your other post.

Dave

 

[K1600]

Ah, I get you now. It was a different question but involving the same code if that makes any sense. I want to be able to change that same code (the one I used of yours) by using a command button to load a different UserForm for maintenance purposes but posted my current code so people could see what I wanted to replicate.

Sorry for the confusion.

Glynn