only one item in listbox being updated? - vba

Question

Hi I have the following code to search and the searched items are displayed in the listbox. I also have an update button that updates whatever new information you input in a textbox. the update box works fine but for some reason when multiple duplicated items are displayed in the listbox and i try to click the 2nd instance and try to update, it updates the original and not the 2nd instance. So, the first instance should update first instance item, and 2nd should update 2nd but right now, 1st is updating 1st instance, 2nd is updating 1st instance, 3rd is updating 1st instance - always updating the 1st instance. how can i fix this? this is the document: https://www.dropbox.com/s/36e9fmbf17wpa0l/example.xlsm
Public Sub Search_Click()
Dim Name As String
Dim f As Range
Dim s As Integer
Dim FirstAddress As String
Dim str() As String
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Master")
Name = surname.Value
With ws
Set f = .Range("A:A").Find(what:=Name, LookIn:=xlValues)
If Not f Is Nothing Then
With Me
firstname.Value = f.Offset(0, 1).Value
tod.Value = f.Offset(0, 2).Value
program.Value = f.Offset(0, 3).Value
email.Value = f.Offset(0, 4).Text
SetCheckBoxes f.Offset(0, 5) '<<< replaces code below
officenumber.Value = f.Offset(0, 6).Text
cellnumber.Value = f.Offset(0, 7).Text
r = f.Row
End With
findnext
FirstAddress = f.Address
Do
s = s + 1
Set f = Range("A:A").findnext(f)
Loop While Not f Is Nothing And f.Address <> FirstAddress
If s > 1 Then
Select Case MsgBox("There are " & s & " instances of " & Name, vbOKCancel Or vbExclamation Or vbDefaultButton1, "Multiple entries")
Case vbOK
findnext
Case vbCancel
End Select
End If
Else: MsgBox Name & "Not Listed"
End If
End With
End Sub
'-----------------------------------------------------------------------------
Sub findnext()
Dim Name As String
Dim f As Range
Dim ws As Worksheet
Dim s As Integer
Dim findnext As Range
Name = surname.Value
Me.ListBox1.Clear
Set ws = ThisWorkbook.Worksheets("Master")
With ws
Set f = .Cells(r, 1)
Set findnext = f
With ListBox1
Do
Debug.Print findnext.Address
Set findnext = Range("A:A").findnext(findnext)
.AddItem findnext.Value
.List(.ListCount - 1, 1) = findnext.Offset(0, 1).Value
.List(.ListCount - 1, 2) = findnext.Offset(0, 2).Value
.List(.ListCount - 1, 3) = findnext.Offset(0, 3).Value
.List(.ListCount - 1, 4) = findnext.Offset(0, 4).Value
.List(.ListCount - 1, 5) = findnext.Offset(0, 5).Value
.List(.ListCount - 1, 6) = findnext.Offset(0, 6).Value
.List(.ListCount - 1, 7) = findnext.Offset(0, 7).Value
.List(.ListCount - 1, 8) = findnext.Offset(0, 8).Value
Loop While findnext.Address <> f.Address
End With
End With
End Sub
'----------------------------------------------------------------------------
Public Sub update_Click()
MsgBox "Directorate has been updated!"
Dim Name As String
Dim f As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Master")
With ws
Set f = .Cells(r, 1)
f.Value = surname.Value
f.Offset(0, 1).Value = firstname.Value
f.Offset(0, 2).Value = tod.Value
f.Offset(0, 3).Value = program.Value
f.Offset(0, 4).Value = email.Value
f.Offset(0, 5).Value = GetCheckBoxes
f.Offset(0, 6).Value = officenumber.Value
f.Offset(0, 7).Value = cellnumber.Value
End With
End Sub

Answer 1

The first obvious problem is r. This global is used as a temporary variable by Search_Click and as a master variable by update_Click.
Consider update_Click. Near the beginning we have:
Set ws = ThisWorkbook.Worksheets("Master")
With ws
Set f = .Cells(r, 1)
If you load the form, fill the fields and click Update then r will not have been initialised so with have the default value of zero.
It is very difficult to guess what this form is attempting to achieve. Most of the buttons do nothing. Of the two buttons that do work, neither is documented. I appreciate this form is under development but, if you are going to ask people to help debug it, you should make it easier to do so.
I assume the objective of update_Click is to add a new row to the bottom of worksheet "Master". If this assumption is true then I suggest the following:
Public Sub update_Click()
MsgBox "Directorate has been updated!"
Dim RowNext As Long
With ThisWorkbook.Worksheets("Master")
' There is no checking of the values entered by the user.
' I have assumed that the surname is present on the last used row.
' If this assumption is untrue, the new data will overwrite the row
' below the last row with a surname.
RowNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Cells(RowNext, "A").Value = surname.Value
.Cells(RowNext, "B").Value = firstname.Value
.Cells(RowNext, "C").Value = tod.Value
.Cells(RowNext, "D").Value = program.Value
.Cells(RowNext, "E").Value = email.Value
.Cells(RowNext, "F").Value = GetCheckBoxes
.Cells(RowNext, "G").Value = officenumber.Value
.Cells(RowNext, "H").Value = cellnumber.Value
End With
End Sub
If you confirm that I am on the right track, I have a look at Search_Click.

Answer 2

The code below is substantial different from yours. Partly this is because your code did not work while, to the extent I have tested it, mine does. But most of the changes are because I did not understand your code. As I worked through your code, I documented it, changed to meaningful names and implemented the effects I thought you were trying to achieve.
When you are creating code, it is important to remember that in six or twelve months you will be back to update it for new requirements. A little time spent making the code easy to understand as you write it can save hours when you need to maintain it. Name variables systematically so you immediately know what they are when you return. Explain what each subroutine and block of code it attempting to achieve so you can find the code you wish to update.
Firstly I have changed your form. I have made the form a little deeper and moved the listbox down. Above the listbox I have inserted a label which I have named lblMessage. This label spans the entire width of the form and is three lines deep. Most of your text is Tahoma 8. This label is Tahoma 10 and is coloured blue. I use it to tell the user what they are expected to do.
As the first line of the form's code I have added:
Option Explicit
Look this statement up to see why it should always be present.
You use Offsets to access the various columns in the worksheet. This can be a nightmare if the columns are every re-arranged. I have used constants:
Const ColMasterFamilyName As String = "A"
Const ColMasterGivenName As String = "B"
Const ColMasterTitle As String = "C"
Const ColMasterProgArea As String = "D"
Const ColMasterEMail As String = "E"
Const ColMasterStakeHolder As String = "F"
Const ColMasterOfficePhone As String = "G"
Const ColMasterCellPhone As String = "H"
This makes my statements much longer than yours but means that instead of 5, say, I have a name.
These constants are named using my system. "Col" says these are columns. "Master" says which worksheet they apply to. "FamilyName" says which column. In your code you use "surname" and "first name". I worked for too many years in an area where "surname" and "first name" were not "culturally sensitive". I am not asking you to like my system but you must have a system. I can look at code I wrote years ago and know what the variables are.
I have replaced your:
Public r As Long
with:
Dim RowEnteredName() As Long
I redimension this array for every select. If only a single row matches the entered name then it is dimensioned as ReDim RowEnteredName(1 To 1) and RowEnteredName(1) holds the row number. If Count rows match the entered name then it is dimensioned as ReDim RowEnteredName(0 To Count). RowEnteredName(0) is not used because it corresponds to the heading line while RowEnteredName(1 To Count) hold the row numbers for each repeat of the name.
I have added a form initialisation routine to prepare the form for use.
I have recoded your findnext as FillListBox because you cannot use keywords as the name for subroutines or variables.
There are routines in your code that I have commented out so that I know the code below is complete.
I hope all this makes sense.
Option Explicit
Const ColMasterFamilyName As String = "A"
Const ColMasterGivenName As String = "B"
Const ColMasterTitle As String = "C"
Const ColMasterProgArea As String = "D"
Const ColMasterEMail As String = "E"
Const ColMasterStakeHolder As String = "F"
Const ColMasterOfficePhone As String = "G"
Const ColMasterCellPhone As String = "H"
Dim RowEnteredName() As Long
Private Sub ListBox1_Click()
'pop listbox when more than one instances are prompted
'cliking the person's name will change the textboxes
'transfer the values to updateclick
Dim RowMasterCrnt As Long
If ListBox1.ListIndex = 0 Then
'Debug.Assert False
lblMessage.Caption = "You cannot select the heading row. Please select a person."
Exit Sub
End If
With ThisWorkbook.Worksheets("Master")
RowMasterCrnt = RowEnteredName(ListBox1.ListIndex)
ReDim RowEnteredName(1 To 1)
RowEnteredName(1) = RowMasterCrnt
surname.Value = .Cells(RowMasterCrnt, ColMasterFamilyName).Value
firstname.Value = .Cells(RowMasterCrnt, ColMasterGivenName).Value
tod.Value = .Cells(RowMasterCrnt, ColMasterTitle).Value
program.Value = .Cells(RowMasterCrnt, ColMasterProgArea).Value
email.Value = .Cells(RowMasterCrnt, ColMasterEMail).Value
Call SetCheckBoxes(.Cells(RowMasterCrnt, ColMasterStakeHolder).Value)
officenumber.Value = .Cells(RowMasterCrnt, ColMasterOfficePhone).Value
cellnumber.Value = .Cells(RowMasterCrnt, ColMasterCellPhone).Value
lblMessage.Caption = "Please change details as required then click [Update]. " & _
"If you have selected the wrong person, " & _
"please click [Select] to reselect."
update.Visible = True
End With
ListBox1.Visible = False ' Cannot use again because RowEnteredName changed
End Sub
Private Sub Search_Click()
' User should have entered a Family name before clicking Search.
If surname.Value = "" Then
Debug.Assert False ' Not tested
lblMessage.Caption = "Please enter a Family name or Surname"
Exit Sub
End If
Dim Name As String
Dim CellNameFirst As Range ' First cell, if any, holding family name
Dim Count As Long
Dim FirstAddress As String
lblMessage.Caption = ""
Name = surname.Value
With ThisWorkbook.Worksheets("Master")
' Look for entered family name in appropriate column
Set CellNameFirst = .Columns(ColMasterFamilyName).Find( _
what:=Name, after:=.Range(ColMasterFamilyName & "1"), _
lookat:=xlWhole, LookIn:=xlValues, _
SearchDirection:=xlNext, MatchCase:=False)
If Not CellNameFirst Is Nothing Then
' There is at least one person with the entered family name.
' Fill the listbox and make it visible if there is more than one person
' with the entered family name
'Debug.Assert False ' Not tested
Call FillListBox(CellNameFirst)
If ListBox1.Visible Then
' There is more than one person with the entered name
' Ensure update not available until selection made from list box
'Debug.Assert False ' Not tested
update.Visible = False
lblMessage.Caption = "Please click the required person within the listbox"
Exit Sub
Else
' Only one person with entered name
' Prepare the entry controls for updating by the user
'Debug.Assert False ' Not tested
ReDim RowEnteredName(1 To 1)
RowEnteredName(1) = CellNameFirst.Row ' Record row for selected family name
firstname.Value = .Cells(RowEnteredName(1), ColMasterGivenName).Value
tod.Value = .Cells(RowEnteredName(1), ColMasterTitle).Value
program.Value = .Cells(RowEnteredName(1), ColMasterProgArea).Value
email.Value = .Cells(RowEnteredName(1), ColMasterEMail).Value
Call SetCheckBoxes(.Cells(RowEnteredName(1), ColMasterStakeHolder).Value)
officenumber.Value = .Cells(RowEnteredName(1), ColMasterOfficePhone).Value
cellnumber.Value = .Cells(RowEnteredName(1), ColMasterCellPhone).Value
lblMessage.Caption = "Please change details as required then click Update"
update.Visible = True
End If
Else
Debug.Assert False ' Not tested
lblMessage.Caption = "No person found with that name. Please try another."
update.Visible = False
End If
End With
End Sub
Public Sub update_Click()
With ThisWorkbook.Worksheets("Master")
.Cells(RowEnteredName(1), "A").Value = surname.Value
.Cells(RowEnteredName(1), "B").Value = firstname.Value
.Cells(RowEnteredName(1), "C").Value = tod.Value
.Cells(RowEnteredName(1), "D").Value = program.Value
.Cells(RowEnteredName(1), "E").Value = email.Value
.Cells(RowEnteredName(1), "F").Value = GetCheckBoxes
.Cells(RowEnteredName(1), "G").Value = officenumber.Value
.Cells(RowEnteredName(1), "H").Value = cellnumber.Value
End With
' Clear controls ready for next select and update
surname.Value = ""
firstname.Value = ""
tod.Value = ""
program.Value = ""
email.Value = ""
Call SetCheckBoxes("")
officenumber.Value = ""
cellnumber.Value = ""
lblMessage.Caption = "Please enter the family name or surname of the " & _
"person whose details are to be updated then " & _
"click [Search]."
update.Visible = False
End Sub
Private Sub UserForm_Initialize()
' Set controls visible or invisible on initial entry to form.
' Update is not available until Search has been clicked and current
' details of a single person has been displayed.
update.Visible = False
' The listbox is only used if Search finds the entered name matches
' two or more people
ListBox1.Visible = False
' Search is the first button to be clicked and is always available
' as a means of cancelling the previous selection.
Search.Visible = True
' Not yet implemented
CommandButton1.Visible = False
CommandButton2.Visible = False
CommandButton3.Visible = False
CommandButton7.Visible = False
lblMessage.Caption = "Please enter the family name or surname of the " & _
"person whose details are to be updated then " & _
"click [Search]."
End Sub
Function ColCodeToNum(ColStg As String) As Integer
' Convert 1 or 2 character column identifiers to number.
' A -> 1; Z -> 26: AA -> 27; and so on
Dim lcColStg As String
lcColStg = LCase(ColStg)
ColCodeToNum = IIf(Len(ColStg) > 1, (Asc(Left(ColStg, 1)) - 64) * 26, 0) + _
Asc(Right(ColStg, 1)) - 64
End Function
Sub FillListBox(CellNameFirst As Range)
' CellNamefirst is the first, possibly only, cell for the
' family name entered by the user.
' Clear the listbox. If there is more than one person with the
' entered family name, make the listbox visible and fill it with
' every person with the same family name
Dim CellName As Range
Dim Count As Long
Dim ListBoxData() As String
Dim RowMasterCrnt As Long
Dim LbEntryCrnt As Long
Me.ListBox1.Clear
Set CellName = CellNameFirst
' Count number of rows with same family name as CellNameFirst
Count = 1
With ThisWorkbook.Worksheets("Master")
Do While True
Set CellName = .Columns(ColMasterFamilyName).findnext(CellName)
If CellName.Row = CellNameFirst.Row Then
'Debug.Assert False
Exit Do
End If
'Debug.Assert False
Count = Count + 1
Loop
End With
If Count = 1 Then
' Only one person has the entered family name
'Debug.Assert False
Me.ListBox1.Visible = False
Exit Sub
End If
'Debug.Assert False
Set CellName = CellNameFirst
ReDim ListBoxData(1 To 8, 0 To Count) ' Row 0 used for column headings
ReDim RowEnteredName(0 To Count)
LbEntryCrnt = 0
With ThisWorkbook.Worksheets("Master")
' Create column headings
ListBoxData(ColCodeToNum(ColMasterFamilyName), LbEntryCrnt) = _
.Cells(2, ColMasterFamilyName).Value
ListBoxData(ColCodeToNum(ColMasterGivenName), LbEntryCrnt) = _
.Cells(2, ColMasterGivenName).Value
ListBoxData(ColCodeToNum(ColMasterTitle), LbEntryCrnt) = _
.Cells(2, ColMasterTitle).Value
ListBoxData(ColCodeToNum(ColMasterProgArea), LbEntryCrnt) = _
.Cells(2, ColMasterProgArea).Value
ListBoxData(ColCodeToNum(ColMasterEMail), LbEntryCrnt) = _
.Cells(2, ColMasterEMail).Value
ListBoxData(ColCodeToNum(ColMasterStakeHolder), LbEntryCrnt) = _
.Cells(2, ColMasterStakeHolder).Value
ListBoxData(ColCodeToNum(ColMasterOfficePhone), LbEntryCrnt) = _
.Cells(2, ColMasterOfficePhone).Value
ListBoxData(ColCodeToNum(ColMasterCellPhone), LbEntryCrnt) = _
.Cells(2, ColMasterCellPhone).Value
LbEntryCrnt = LbEntryCrnt + 1
Do While True
' For each row with the same family name, add details to array
RowMasterCrnt = CellName.Row
ListBoxData(ColCodeToNum(ColMasterFamilyName), LbEntryCrnt) = _
.Cells(RowMasterCrnt, ColMasterFamilyName).Value
ListBoxData(ColCodeToNum(ColMasterGivenName), LbEntryCrnt) = _
.Cells(RowMasterCrnt, ColMasterGivenName).Value
ListBoxData(ColCodeToNum(ColMasterTitle), LbEntryCrnt) = _
.Cells(RowMasterCrnt, ColMasterTitle).Value
ListBoxData(ColCodeToNum(ColMasterProgArea), LbEntryCrnt) = _
.Cells(RowMasterCrnt, ColMasterProgArea).Value
ListBoxData(ColCodeToNum(ColMasterEMail), LbEntryCrnt) = _
.Cells(RowMasterCrnt, ColMasterEMail).Value
ListBoxData(ColCodeToNum(ColMasterStakeHolder), LbEntryCrnt) = _
.Cells(RowMasterCrnt, ColMasterStakeHolder).Value
ListBoxData(ColCodeToNum(ColMasterOfficePhone), LbEntryCrnt) = _
.Cells(RowMasterCrnt, ColMasterOfficePhone).Value
ListBoxData(ColCodeToNum(ColMasterCellPhone), LbEntryCrnt) = _
.Cells(RowMasterCrnt, ColMasterCellPhone).Value
RowEnteredName(LbEntryCrnt) = RowMasterCrnt
LbEntryCrnt = LbEntryCrnt + 1
Set CellName = .Columns(ColMasterFamilyName).findnext(CellName)
If CellName.Row = CellNameFirst.Row Then
Exit Do
End If
Loop
End With
Me.ListBox1.Column = ListBoxData ' Write array to listbox
ListBox1.Visible = True
End Sub
'Get the checked checkboxes as a space-separated string
Function GetCheckBoxes() As String
Dim arrStakeHolderAll() As Variant
Dim i As Long
Dim rv As String
'Debug.Assert False
arrStakeHolderAll = WhatCheckboxes()
rv = ""
For i = LBound(arrStakeHolderAll) To UBound(arrStakeHolderAll)
'Debug.Assert False
If Me.Controls(arrStakeHolderAll(i)).Value = True Then
'Debug.Assert False
rv = rv & IIf(Len(rv) > 0, " ", "") & arrStakeHolderAll(i)
End If
Next i
GetCheckBoxes = rv
End Function
Sub SetCheckBoxes(strList As String)
' Populate checkboxes from space-separated values in strList.
' Pass "" to just clear checkboxes
Dim arrStakeHolderAll() As Variant
Dim arrStakeHolderCrnt() As String
Dim i As Long
Dim tmp As String
'Debug.Assert False
PACT.Value = False
PrinceRupert.Value = False
WPM.Value = False
Montreal.Value = False
TET.Value = False
TC.Value = False
US.Value = False
Other.Value = False
arrStakeHolderAll = WhatCheckboxes()
If Len(strList) > 0 Then
'Debug.Assert False
arrStakeHolderCrnt = Split(strList, " ")
For i = LBound(arrStakeHolderCrnt) To UBound(arrStakeHolderCrnt)
'Debug.Assert False
tmp = Trim(arrStakeHolderCrnt(i))
If Not IsError(Application.Match(tmp, arrStakeHolderAll, 0)) Then
'Debug.Assert False
Me.Controls(tmp).Value = True
End If
Next i
End If
End Sub
'returns the name of all Stakeholder checkboxes
Function WhatCheckboxes() As Variant()
'Debug.Assert False
WhatCheckboxes = Array("PACT", "PrinceRupert", "WPM", _
"Montreal", "TET", "TC", "US", "Other")
End Function