Helpwith my password sreadsheet please.

[davidwh000]

Hi, I would like to modify the code within my spreadsheet to allow duplicate entries to be made. At present if the data in box 1 or 2 does not change then it does not allow me to save the new entry even if the dat in the other boxes is different.I have merged features from several other solutions in this one and as a novice am unable to find the detail which prevents me from storing entries with the same data in boxes 1 and 2. I feel sure it is quite simple but I cannot fathom the answer. Code below. Help appreciated please. David

Option Explicit
Dim ctl As Control
Dim Answer As VbMsgBoxResult    '*  I don't use this but I've left here if you want to use it
Dim lastRow As Long, i As Long, x As Long, r As Long
Dim vList As Variant
Dim z, ary
Dim tbl As ListObject           '*  to address the Table in Sheet1
Dim ws As Worksheet             '*  to reference the worksheet
Dim sortcolumn As Range


Private Sub UserForm_Initialize()
populate_ListBox                '*  populates the listbox
reset_TextBoxes                 '*  clears the 12 textboxes in Frame2
reset_OptionButtons             '*  sets the OptionsButtons (3) to false
Me.TextBox13.SetFocus           '*  sets focus to the searchbox
End Sub

Private Sub refresh_Listbox()
sort_Table                      '*  sorts the table
UserForm_Initialize             '*  calls the initialization routine
Me.ListBox1.Enabled = True
End Sub

Private Sub reset_TextBoxes()   '*  clears the 12 texboxes and makes sure the back color is none
For Each ctl In Me.Frame2.Controls
    Select Case TypeName(ctl)
    Case "TextBox"
        ctl.Text = ""
        Me.Controls(ctl.Name).BackColor = noBack
        Me.Controls(ctl.Name).Enabled = True
    End Select
Next ctl
Me.TextBox13.Enabled = True     '*  enables the serachbox which is disabled after an option button has been clicked
Me.Frame2.Tag = ""              '*  Tag value in Frame2 is cleared, the Tag value will hold the table row number of the selected record
End Sub

Private Sub check_TextBoxes()   '*  checks if the first 5 textboxes contain data, if not the backcolour is set to light red
For i = 1 To 5
    Controls("TextBox" & i).BackColor = IIf(Controls("TextBox" & i) = "", lRed, noBack)
    If i = 9 Then
        Controls("TextBox" & i).BackColor = noBack
        If Controls("TextBox" & i) <> "" Then
            If IsEMailAddress(Controls("TextBox" & i), tellMe:=False) = False Then Controls("TextBox" & i).BackColor = lRed
        End If
    End If
Next i
End Sub

Private Function data_OK_2_Process() As Boolean '*  this routine checks if the 5 textboxes contain data
check_TextBoxes
For i = 1 To 5
    If Controls("TextBox" & i).BackColor = lRed Then MsgBox "Data entry is incomplete!", vbCritical + vbOKOnly, "Data incomplete !": Exit Function
Next i
data_OK_2_Process = True
End Function

Private Sub cmdPrint_Click()    '*  added the prompt if you want to print, you cannot just print
Application.Dialogs(xlDialogPrinterSetup).Show
If MsgBox("Selected printer: " & Application.ActivePrinter & vbCrLf & vbCrLf & "Print table now?", vbQuestion + vbYesNo, "Print?") <> vbYes Then Exit Sub
ThisWorkbook.Sheets("Sheet1").PrintOut copies:=1
End Sub

Private Sub cmdExit_Click()
If MsgBox("Are you sure you wish to Exit?", vbYesNo + vbQuestion, "Exit?") <> vbYes Then Exit Sub
sort_Table
Unload PasswordRecordForm
End Sub

Private Sub cmdReset_Click()
If MsgBox("Do you wish to reset the form?", vbYesNo + vbQuestion, "Reset List?") <> vbYes Then Exit Sub
Me.TextBox13 = ""
UserForm_Initialize
'reset_TextBoxes
'reset_OptionButtons
End Sub

Private Sub reset_OptionButtons()   '*  resets the three option buttons and enabled them again
With Me
    .OptBtnNew.Value = False
    .OptBtnEdit.Value = False
    .OptBtnDelete.Value = False
    .OptBtnNew.Enabled = True
    .OptBtnEdit.Enabled = True
    .OptBtnDelete.Enabled = True
    .cmdExecute.Caption = "- - -"
    .SpinButton1.Enabled = True
End With
End Sub

Private Sub cmdExecute_Click()  '*  one button to Add, Update and / or Delete a record, depending on the button's caption
Select Case Me.cmdExecute.Caption
Case Is = "Add New Record"
    cmdAddData_Click
Case Is = "Update Record"
    cmdUpdate_Click
Case Is = "Delete Record"
    cmdDelete_Click
Case Else
    Exit Sub
End Select
End Sub

Private Sub OptBtnNew_Click()   '*  New record form is cleared and set to enter data all other buttons are disabled
reset_TextBoxes
With Me
    '.TextBox13.Enabled = False
    '.SpinButton1.Enabled = False
    .OptBtnDelete.Enabled = False
    .OptBtnEdit.Enabled = False
    .cmdExecute.Caption = "Add New Record"
    .TextBox1.SetFocus
    .ListBox1.Enabled = False
End With
End Sub

Private Sub cmdAddData_Click()
If data_OK_2_Process = False Then Exit Sub      '*  check if all data is filled
If add_data_record(Me) = False Then Exit Sub    '*  returns false if new record could not be saved, i.e. duplicate record
reset_TextBoxes
refresh_Listbox
End Sub

Private Sub OptBtnDelete_Click()
If Me.ListBox1.ListIndex < 0 Then               '*  checks if a record has been selected
    Me.OptBtnDelete.Value = False
    Exit Sub
End If
With Me                                         '*  disables all the nn-relevant buttons
    .TextBox13.Enabled = False
    .SpinButton1.Enabled = False
    .OptBtnEdit.Enabled = False
    .OptBtnNew.Enabled = False
    .cmdExecute.Caption = "Delete Record"
    .cmdExecute.SetFocus
    .ListBox1.Enabled = False
End With
End Sub

Private Sub cmdDelete_Click()
If Me.ListBox1.ListIndex < 0 Then Exit Sub
If delete_data_record(Me) = False Then Exit Sub
refresh_Listbox
reset_TextBoxes
End Sub

Private Sub OptBtnEdit_Click()
If Me.ListBox1.ListIndex < 0 Then           '*  checks if a record has been selected
    Me.OptBtnEdit.Value = False
    Exit Sub
End If
With Me
    .TextBox13.Enabled = False
    .SpinButton1.Enabled = False
    .OptBtnDelete.Enabled = False
    .OptBtnNew.Enabled = False
    .cmdExecute.Caption = "Update Record"
    '.TextBox1.Enabled = False
    '.TextBox2.Enabled = False
    '.TextBox3.SetFocus
    .TextBox1.SetFocus
    .ListBox1.Enabled = False
End With
End Sub

Private Sub cmdUpdate_Click()
If Me.ListBox1.ListIndex < 0 Then Exit Sub
If data_OK_2_Process = False Then Exit Sub
If Not update_data_record(Me) Then Exit Sub
reset_TextBoxes
refresh_Listbox
End Sub

Private Sub TextBox13_Change()              '*  this is the search textbox, you can type anything here and the listbox will be populated as long as one of the 12 table column fields contains the string value
populate_ListBox
If Me.ListBox1.ListCount = 0 And Len(Me.TextBox13) >= 1 Then Me.TextBox13 = Left(Me.TextBox13, Len(Me.TextBox13) - 1)
End Sub

Private Sub TextBox9_Exit(ByVal Cancel As MSForms.ReturnBoolean)    '*  eMail field and check if entered value is valid email address format
If Len(Trim(Me.TextBox9)) = 0 Then Exit Sub
Me.TextBox9.BackColor = noBack
If IsEMailAddress(Me.TextBox9) = False Then Me.TextBox9.BackColor = lRed: Me.TextBox9.SetFocus
End Sub

Private Sub populate_ListBox()
'*
Call Filter_Table(Me)
reset_TextBoxes
Me.ListBox1.Enabled = True
End Sub

Private Sub ListBox1_Click()
If Me.ListBox1.ListCount = 0 Then Exit Sub
If Me.ListBox1.ListIndex < 0 Then Exit Sub
If IsNull(ListBox1.List(ListBox1.ListIndex, 9)) Then Exit Sub
r = ListBox1.List(ListBox1.ListIndex, 9)
Set ws = Sheet1
Set tbl = ws.ListObjects("Table1")
For i = 1 To 12
    Controls("TextBox" & i).Value = tbl.DataBodyRange.Cells(r, i).Text
Next i
Me.Frame2.Tag = ListBox1.List(ListBox1.ListIndex, 9)
End Sub

Private Sub SpinButton1_SpinDown()
Set ws = Sheet1
Set tbl = ws.ListObjects("Table1")
With SpinButton1
    .Max = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    .Min = 3
    x = .Value
    Me.ListBox1.ListIndex = x - 3
    For i = 1 To 12
        Controls("TextBox" & i).Value = Sheet1.Cells(x, i).Value
    Next i
End With
'Me.Frame2.Tag = ListBox1.List(ListBox1.ListIndex, 9)
End Sub

Private Sub SpinButton1_SpinUp()
Set ws = Sheet1
Set tbl = ws.ListObjects("Table1")
With SpinButton1
    .Max = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    .Min = 3
    x = .Value
    Me.ListBox1.ListIndex = x - 3
    For i = 1 To 12
        Controls("TextBox" & i).Value = Sheet1.Cells(x, i).Value
    Next i
End With
'Me.Frame2.Tag = ListBox1.List(ListBox1.ListIndex, 9)
End Sub

Private Sub sort_Table()
Set ws = Sheet1
Set tbl = ws.ListObjects("Table1")
Set sortcolumn = Range("Table1[Account]")
With tbl.Sort
   .SortFields.Clear
   .SortFields.Add Key:=Range("Table1[Category]"), SortOn:=xlSortOnValues, Order:=xlAscending
   .SortFields.Add Key:=Range("Table1[Account]"), SortOn:=xlSortOnValues, Order:=xlAscending
   .Header = xlYes
   .Apply
End With
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    ' This is to force the user to use the Cancel / Exit button
    If CloseMode = vbFormControlMenu Then
        Cancel = True
    End If
    Me.cmdExit.SetFocus
End Sub

 

[dmt32]

Hi,
glancing at your code I suspect that the issue you are trying to overcome may be with in the procedure being called from here

Private Sub cmdAddData_Click()
If data_OK_2_Process = False Then Exit Sub '* check if all data is filled
If add_data_record(Me) = False Then Exit Sub '* returns false if new record could not be saved, i.e. duplicate record
reset_TextBoxes
refresh_Listbox
End Sub

which you have not shared.

It would be helpful if you could share the code or better, place copy of your workbook with dummy data in a file sharing site like DropBox & provide a link to it.
Plenty here to offer guidance

Dave

 

[davidwh000]

Hi,
glancing at your code I suspect that the issue you are trying to overcome may be with in the procedure being called from here

Private Sub cmdAddData_Click()
If data_OK_2_Process = False Then Exit Sub '* check if all data is filled
If add_data_record(Me) = False Then Exit Sub '* returns false if new record could not be saved, i.e. duplicate record
reset_TextBoxes
refresh_Listbox
End Sub

which you have not shared.

It would be helpful if you could share the code or better, place copy of your workbook with dummy data in a file sharing site like DropBox & provide a link to it.
Plenty here to offer guidance

Dave

Thank you Dave, much appreciaited.Please see link to dropbox where I have shared the full file.

Working doc PWDStest 02.xlsm

Shared with Dropbox

www.dropbox.com

David

 

[dmt32]

Hi,
If you want to allow duplicates then try deleting section of code shown in RED & see if this does what you want

Public Function add_data_record(uForm As UserForm) As Boolean
If check_4_Duplicate(uForm) = True Then
    MsgBox "There is already an entry for " & uForm.TextBox1 & vbCrLf & uForm.TextBox2, vbExclamation, "Duplicate record!"
    Exit Function
End If
Set wsD = Sheet1
Set tbl = wsD.ListObjects("Table1")
Dim lastRow As Long, i  As Integer
If MsgBox("Do you wish to add the data for " & uForm.TextBox1 & vbCrLf & uForm.TextBox2 & " to the form?", vbYesNo + vbQuestion, "Add Data?") = vbYes Then
    lastRow = tbl.HeaderRowRange.Row + tbl.DataBodyRange.Rows.Count
    If wsD.Cells(lastRow, 1) = "" Then lastRow = lastRow - 1
    For i = 1 To 12
        wsD.Cells(lastRow + 1, i).Value = uForm.Controls("TextBox" & i).Value
    Next i
    add_data_record = True
End If
End Function

Dave

 

[davidwh000]

Hi,
If you want to allow duplicates then try deleting section of code shown in RED & see if this does what you want

Public Function add_data_record(uForm As UserForm) As Boolean
If check_4_Duplicate(uForm) = True Then
    MsgBox "There is already an entry for " & uForm.TextBox1 & vbCrLf & uForm.TextBox2, vbExclamation, "Duplicate record!"
    Exit Function
End If
Set wsD = Sheet1
Set tbl = wsD.ListObjects("Table1")
Dim lastRow As Long, i  As Integer
If MsgBox("Do you wish to add the data for " & uForm.TextBox1 & vbCrLf & uForm.TextBox2 & " to the form?", vbYesNo + vbQuestion, "Add Data?") = vbYes Then
    lastRow = tbl.HeaderRowRange.Row + tbl.DataBodyRange.Rows.Count
    If wsD.Cells(lastRow, 1) = "" Then lastRow = lastRow - 1
    For i = 1 To 12
        wsD.Cells(lastRow + 1, i).Value = uForm.Controls("TextBox" & i).Value
    Next i
    add_data_record = True
End If
End Function

Dave

Thank you very much Dave, I did not even know that section of code was there. I most definately would like to go on a course to learn more about using VBA and Excel as it is so useful and as an oldie could do with some lessons. Thanks again, you have solved my problem and made my day.
David

 

[dmt32]

I most definately would like to go on a course to learn more about using VBA and Excel as it is so useful and as an oldie could do with some lessons.

I retired over 20 years ago & whilst memory plays tricks age is no barrier (well that's what I am told!)

Thanks again, you have solved my problem and made my day.
David

You are welcome & appreciate the feedback

Dave