Userform for Data Entry Into Several Different Worksheets

T

TheJay

Active Member
Joined
Nov 12, 2014
Messages
364
Office Version
  1. 2019
Platform
  1. Windows
I am creating a userform to search and manage a list of contacts.

There is currently no search facility whilst I work on getting the data input/edit capability running as it should.
PhwEWSy.png

ZhnyjMN.png


The first function I am trying to implement is decribed below.

The master linked accounts section is hidden unless the corresponding worksheets are selected where this information is applicable. When one of the worksheets that this information is relevant to is selected in the combobox, it should populate MLA option buttons.

I have two option buttons to the form 'MLA' called 'mstrYes' and 'mstrNo'. 'mstrNo' should be the default and I want to prevent the text box 'txt7' from appearing until mstrYes is selected, and if mstrNo is selected again, the text box should disappear again.

Also in relation to the text box 'txt7', how do I prevent the text within 'txt7' that appears automatically in 'Example1, Example2, Example3' mentioned previously from being cleared during the following procedure?

Code: 
Dim ws As Worksheet

Private Sub cbContactType_Change()
    Me.cmdbNew.Enabled = CBool(Me.cbContactType.ListIndex <> -1)
    If Me.cbContactType.Enabled Then Set ws = Worksheets(cbContactType.Text)
    Me.txt7.Visible = Not IsError(Application.Match(cbContactType.Text, Array("Housing Associations", "Landlords"), False))
    Me.mstrAccounts.Visible = Me.txt7.Visible
    Me.MLA.Visible = Me.txt7.Visible
End Sub




Private Sub iptSearch_Click()
      Contacts.Hide
      Unload Contacts
End Sub




'Private Sub cmdbChange_SpinUp()
'    If Me.cbContactType.ListRows.Count < 1 Then Exit Sub
'    If CurrentRow > 1 Then
'        CurrentRow = CurrentRow - 1
'        UpdatecmdbChange
'    End If
'End Sub




'Private Sub cmdbChange_SpinDown()
'    If CurrentRow = Me.cbContactType.ListRows.Count Then Exit Sub
'    If CurrentRow < Me.cbContactType.ListRows.Count Then
'        CurrentRow = CurrentRow + 1
'        UpdatecmdbChange
'    End If
'End Sub




'Private Sub UpdatePositionCaption()
'    dtaRow.Caption = CurrentRow & " of " & Me.cbContactType.ListRows.Count
'End Sub




Private Sub UserForm_Initialize()
    Me.cbContactType.List = Array("Council Contacts", "Local Contacts", "Housing Associations", "Landlords", "Letting and Selling Agents", "Developers", "Employers")
    Me.cmdbNew.Enabled = False
    Me.txt7.Visible = False
    Me.mstrAccounts.Visible = False
    Me.MLA.Visible = False
End Sub




Private Sub cmdbNew_Click()
Dim cNum As Integer, X As Integer
    Dim nextrow As Long
    nextrow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    If Len(ws.Cells(1, 2).Value) > 0 Then nextrow = nextrow + 1
    cNum = 7
    Dim AlignLeft As Boolean
    For X = 1 To cNum
    AlingLeft = CBool(X = 1 Or X = 7)
    With ws.Cells(nextrow, X + 1)
        .Value = Me.Controls("txt" & X).Value
        .EntireColumn.AutoFit
        .HorizontalAlignment = IIf(X = 1, xlLeft, xlCenter)
        .VerticalAlignment = xlCenter
        With .Font
             .Name = "Arial"
             .FontStyle = "Regular"
             .Size = 10
        End With
    End With
    Me.Controls("txt" & X).Text = ""
    Next
    MsgBox "Contact added to " & ws.Name, 64, "Contact Added"
End Sub




Private Sub cmdbClose_Click()
Unload Me
End Sub
 
Sort by date Sort by votes
With the delete function, it needs to come up with a prompt asking if the user is sure that they want to delete '$name of contact$' and then populate the new contents of the same row (data gets moved up when deleted row above deleted).
 
Last edited:
Upvote 0

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Using code above, there is a problem.

Private Sub cbContactType_Change()

Copile error: Variable not defined

Code: 
For i = 1 To 7

Highlighting 'i'.
 
Upvote 0
Delete code could be something along the lines of:

Code: 
Dim smessage As String
    smessage = "Are you sure you want to delete? " & vbCrLf + vbCrLf + Chr(32) + txt2.Text + Chr(32) + txt1.Text
    If MsgBox(smessage, vbQuestion + vbYesNo, _
              "Confirm Delete") = vbYes Then
        
Dim LastRow As Long, i As Long

'find last row of data in column A
LastRow = Columns(1).Find("*", SearchDirection:=xlPrevious).Row

'loop from last row to row 1
For i = LastRow To 1 Step -1
    If Cells(i, "A") = txt1.Text And Cells(i, "B") = txt2.Text And Cells(i, "G") = cbContactType.Text Then
        Rows(i).Delete

Although cell references aren't quite right so when I tested it it didn't work.

Compile error: Block If without End If.
 
Upvote 0
Sheepdisease said:
Using code above, there is a problem.

Private Sub cbContactType_Change()

Copile error: Variable not defined

Code: 
For i = 1 To 7

Highlighting 'i'.
Click to expand...

My fault: I forgot to mention to add the following to the variable declarations at the top of the userform module:

Code: 
Dim i as Integer

Regards,

CJ
 
Upvote 0
Sheepdisease said:
Delete code could be something along the lines of:

Code: 
Dim smessage As String
    smessage = "Are you sure you want to delete? " & vbCrLf + vbCrLf + Chr(32) + txt2.Text + Chr(32) + txt1.Text
    If MsgBox(smessage, vbQuestion + vbYesNo, _
              "Confirm Delete") = vbYes Then
        
Dim LastRow As Long, i As Long

'find last row of data in column A
LastRow = Columns(1).Find("*", SearchDirection:=xlPrevious).Row

'loop from last row to row 1
For i = LastRow To 1 Step -1
    If Cells(i, "A") = txt1.Text And Cells(i, "B") = txt2.Text And Cells(i, "G") = cbContactType.Text Then
        Rows(i).Delete

Although cell references aren't quite right so when I tested it it didn't work.

Compile error: Block If without End If.
Click to expand...

I don't think all of this will be necessary as you already have CurrentRow pointing to the data you want to delete. Instead, after your message box lines, just use (UNTESTED at the moment):

Code: 
ws.EntireRow(CurrentRow).delete

Also, in your message box line: vbCrLf & Chr(32) essentially do the same thing so use one or the other. And change the "+"s to "&"s.

Regards,

CJ
 
Upvote 0
Thank you. Now the code is as follows:

Code: 
Option ExplicitDim objCtrl As Control
Dim cNum As Integer, X As Integer
Dim nextrow As Long
Dim AlignLeft As Boolean
Dim i As Integer


Private Sub UserForm_Initialize()
    cbContactType.List = Array("Council Contacts", "Local Contacts", "Housing Associations", "Landlords", "Letting and Selling Agents", "Developers", "Employers")
    cmdbNew.Enabled = False
    txt7.Visible = False
    mstrAccounts.Visible = False
    MLA.Visible = False
    mstrNo.Value = True
        
        For Each objCtrl In Me.Controls
            If Left(objCtrl.Name, 4) = "Text" Then txt7.Visible = False
        Next
        If txt7.Value = "" Then
            txt7.Value = "Example1: " & vbCrLf & "Example2: " & vbCrLf & "Example3: "
        End If
End Sub
Private Sub cbContactType_Change()
    cmdbNew.Enabled = CBool(cbContactType.ListIndex <> -1)
    
    If cbContactType.Enabled Then Set ws = Worksheets(cbContactType.Text)
    
    If cbContactType.Value = "Housing Associations" Or _
       cbContactType.Value = "Landlords" Then
       mstrAccounts.Visible = True
       MLA.Visible = True
    Else
        mstrAccounts.Visible = False
        MLA.Visible = False
    End If
    
    lastRow = ws.Range("B" & Rows.Count).End(xlUp).Row
    CurrentRow = lastRow
    
    'loop thru and clear textboxes
    For i = 1 To 7
        Contacts.Controls("txt" & i).Value = ""
    Next i
    
    Contacts.dtaRow.Caption = lastRow - 1 & " Record(s)"
End Sub
Private Sub cmdbChange_SpinDown()
    If CurrentRow > 2 Then
        CurrentRow = CurrentRow - 1
        UpdatecmdbChange
    End If
End Sub
Private Sub cmdbChange_SpinUp()
    If CurrentRow < lastRow Then
        CurrentRow = CurrentRow + 1
        UpdatecmdbChange
    End If
End Sub
Private Sub iptSearch_Click()
    Contacts.Hide
    Unload Contacts
End Sub
Private Sub cmdbUpdate_Click()
    'yet to be completed
End Sub
Private Sub cmdbDelete_Click()
Dim smessage As String
    smessage = "Are you sure you want to delete? " & vbCrLf & vbCrLf & vbCrLf & txt2.Text & vbCrLf & txt1.Text
    If MsgBox(smessage, vbQuestion & vbYesNo, _
              "Confirm Delete") = vbYes Then
    ws.EntireRow(CurrentRow).Delete
End Sub
Private Sub mstrYes_Click()
    txt7.Visible = True
End Sub
Private Sub mstrNo_Click()
    txt7.Visible = False
End Sub
Private Sub cmdbNew_Click()
    If txt1.Value = "" And txt2.Value = "" And txt3.Value = "" _
        And txt4.Value = "" And txt5.Value = "" And txt6.Value = "" Then
        MsgBox "Please enter data into at least one field.", 64, "Error"
        Exit Sub
    End If
    nextrow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    If Len(ws.Cells(1, 2).Value) > 0 Then nextrow = nextrow + 1
        If txt7.Visible = True Then
            cNum = 7
        Else
            cNum = 6
        End If
    For X = 1 To cNum
        AlignLeft = CBool(X = 1 Or X = 7)
        With ws.Cells(nextrow, X + 1)
            .Value = Me.Controls("txt" & X).Value
            .EntireColumn.AutoFit
            .HorizontalAlignment = IIf(X = 1 Or X = 7, xlLeft, xlCenter)
            .VerticalAlignment = xlCenter
                With .Font
                     .Name = "Arial"
                     .FontStyle = "Regular"
                     .Size = 10
                End With
        End With
        Controls("txt" & X).Text = ""
    Next
    MsgBox "Contact added to " & ws.Name, 64, "Success"
    Application.ScreenUpdating = False
    Unload Me
    Contacts.Show
    Application.ScreenUpdating = True
End Sub
Private Sub cmdbClose_Click()
Unload Me
End Sub

The delete code:
Code: 
Private Sub cmdbDelete_Click()
Dim smessage As String
    smessage = "Are you sure you want to delete? " & vbCrLf & vbCrLf & vbCrLf & txt2.Text & vbCrLf & txt1.Text
    If MsgBox(smessage, vbQuestion & vbYesNo, _
              "Confirm Delete") = vbYes Then
    ws.EntireRow(CurrentRow).Delete
End Sub

Compile error: Method or data member not found
Highlighting 'EntireRow'
 
Upvote 0
Ok, I tested the following code and it worked for me:

Code: 
Private Sub cmdbDelete_Click()
Dim smessage As String
    smessage = "Are you sure you want to delete? " & vbCrLf & vbCrLf & vbCrLf & txt2.Text & vbCrLf & txt1.Text
    If MsgBox(smessage, vbQuestion & vbYesNo, _
              "Confirm Delete") = vbYes Then
        ws.Rows(CurrentRow).Delete
    End If
End Sub

Regards,

CJ
 
Upvote 0
Thank you, that does work. I am trying to customise the message but can't get it to work for some reason, what is wrong with this?

Code: 
Private Sub cmdbDelete_Click()Dim smessage As String
    smessage = "Are you sure you want to delete this contact?" & vbCrLf & vbCrLf & "Name: '" & txt2.Text & "' & vbCrLf & "From: '" & txt1.Text & "'
    If MsgBox(smessage, vbQuestion & vbYesNo, _
              "Confirm Delete") = vbYes Then
    ws.Rows(CurrentRow).Delete
    End If
End Sub

Also, is there a way for the code to work whether there is a table or not? Can it check whether a particular worksheet contains a table or not and then behave accordingly?
 
Upvote 0
Why do you have the single quote marks (') in there? Eliminate those and it should work just fine.

I'll take a look at the table row count issue tomorrow. It's late and my bed is calling :).

Regards,

CJ
 
Upvote 0
Thank you for your help, I hope you sleep well. I just tried your suggestion but now I am getting a compile error.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
Calendar form cancel button passing data to worksheet
Replies
7
Views
1K
AndyEd
A
M
  • Solved
How to update worksheet table data using userform listbox
Replies
3
Views
950
dmt32
D
I
  • Solved
Userform to worksheet values followed by 3 digits
Replies
2
Views
381
ipbr21054
I
A
  • Solved
make faster code after increase data for 4000 rows for each sheet on userform
2
Replies
13
Views
1K
Akuini
Akuini
A
  • Solved
add another condition to filter data based on month in listbox on userform
Replies
3
Views
565
abdelfattah
A

Forum statistics

Threads
1,223,922
Messages
6,175,384
Members
452,639
Latest member
RMH2024

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top