Wanna make a Userform Close and Save - Then open a different workbook?

[Wanting2Excel]

Hi again guys.

Ok so my problem is pretty much what it says in thread title. I have a workbook (WB1) that needs to be read only. Its going to be used by lots of people so don't want them messing things up. But some of the sheets in WB1, users will enter data on via a userform - So on WB1 I have a button with a link to the data sheet which is not read only (WB2). I have created the Userform and the code to populate the data onto WB2, it then saves and closes the sheet (WB2). But I want it to then take them back to WB1 - So that it seemlesly seems to anyone else that they never left the read only sheet to begin with....Does that make sense?

Here is the code I have so far:

Private Sub cmdSubmit_Click()

Dim RowCount As Long


    If Me.txtDate.Value = "" Then
        MsgBox "Please enter the date.", vbExclamation, "All fields need to be completed."
        Me.txtDate.SetFocus
        Exit Sub
        If Not IsNumeric(Me.txtDate.Value) Then
    MsgBox "The Amount box must contain a number.", vbExclamation, "Please enter date in dd/mm/yyyy format."
    Me.txtDate.SetFocus
    Exit Sub
End If
    MsgBox "The Date box must contain a date.", vbExclamation, "Staff Expenses"
    Me.txtDate.SetFocus
    Exit Sub
    
    End If
        If Me.txtName.Value = "" Then
        MsgBox "Please enter your name.", vbExclamation, "All fields need to be completed"
        Me.txtName.SetFocus
        Exit Sub
    End If
      If Me.txtQuestion.Value = "" Then
        MsgBox "Please enter your question.", vbExclamation, "All fields need to be completed"
        Me.txtQuestion.SetFocus
        Exit Sub
    End If


' Write data to Worksheet
        RowCount = Worksheets("Sheet1").Range("A1").CurrentRegion.Rows.Count
        With Worksheets("Sheet1").Range("A1")
             .Offset(RowCount, 0).Value = Me.txtDate.Value
             .Offset(RowCount, 1).Value = Me.txtName.Value
             .Offset(RowCount, 2).Value = Me.txtQuestion.Value
             
             ActiveWorkbook.Save
             ActiveWorkbook.Close
             
             
                     
        Exit Sub
    
End With
End Sub

What (if anything) can I do to make WB1 open after clicking submit on the userform to save and close WB2?

 

[dmt32]

Sounds like you are wanting to save your data to a central database workbook which can be done.

I have put together some test code for you to play with & but is untested & will most likely need further work by you to suit need. Its should be self explanatory but note the second procudure (function) this is to test that WB2 is not already open by another user saving their data.

UserForm Code:

Private Sub cmdSubmit_Click()
    Dim DBFile As String
    Dim DestPath As String
    Dim DestFile As String
    Dim Passwrd As String
    Dim msg As String
    Dim DestWS As Worksheet
    Dim DestWB As Workbook
    Dim i As Integer
    Dim mydate As Date
    'check textbox entries
    Dim Ctrl As Control
    For Each Ctrl In Me.Controls
        If TypeName(Ctrl) = "TextBox" Then
            Select Case Ctrl.Name
            Case "TxtDate"
                mydate = IsDate(Ctrl.Value)
                If Not mydate Then msg = "Please Enter A Valid Date": Ctrl.SetFocus: Exit For
            Case "TxtName"
                If Ctrl.Value = "" Then msg = "Please Enter Your Name": Ctrl.SetFocus: Exit For
            Case Else
                If Ctrl.Value = "" Then msg = "Please Enter Your Question": Ctrl.SetFocus: Exit For
            End Select
        End If
    Next Ctrl
    If msg <> "" Then
        MsgBox msg, vbExclamation, "All fields need to be completed"
        Exit Sub
    End If

    'destination path & file name of WB2
    'change as required
    DestPath = "C:\mypath1\mypath2\"    'path where your WB2 is located
    DestFile = "DatabaseFile.xls"       'name of WB2
    DBFile = DestPath & DestFile
    'Check if Read / Write File Already Open
    i = 1
checkfile:
    If FileLocked(DBFile) Then
        'read / write file open wait 1 second & try again
        Application.Wait (Now + TimeValue("0:00:1"))
        i = i + 1
        'have 3 goes
        If i > 4 Then MsgBox "File In Use": Exit Sub
        GoTo checkfile
    Else
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
            .DisplayAlerts = False
        End With
        Passwrd = ""    ' change as required
        Set DestWB = Workbooks.Open(DBFile, False, ReadOnly:=False, Password:=Passwrd)
        Set DestWS = DestWB.Worksheets("Sheets1")
        ' Write data to Worksheet
        With DestWS
            RowCount = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            .Cells(RowCount, 1).Value = Me.TxtDate.Value
            .Cells(RowCount, 2).Value = Me.TxtName.Value
            .Cells(RowCount, 3).Value = Me.TxtQUESTION.Value
        End With
        DestWB.Close True
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
            .DisplayAlerts = True
        End With
        MsgBox "Data Has Been Saved"
    End If
End Sub

Function Code (can go in standard module)

Function FileLocked(strFileName As String) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''
'Function tests if file open Read / Write
'''''''''''''''''''''''''''''''''''''''''''''''''''
    On Error Resume Next
    ''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' If the file is already opened by another process,
    ' and the specified type of access is not allowed,
    ' the Open operation fails and an error occurs.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''
    Open strFileName For Binary Access Read Lock Read As #1
    Close #1
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' If an error occurs, the document is currently open.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    If Err.Number <> 0 Then
        FileLocked = True
        Err.Clear
    End If
End Function

Good luck

Dave

 

[Wanting2Excel]

Urgh more code lol! - Not you, I'm pretty new to VBA but I'm picking it up quick. This is just 1 aspect of a much bigger project that I'm working on and teaching myself as I go - I'm starting to see code in my sleep lol.

Thanks this looks great - I think i get it but I'll play and I reckon I should be able to work it out. Actually having quite a lot of fun doing it but at the same time this is gonna be used by over a hundred of my colleges so no pressure lol.

Thanks again