列表框中只有一个项目正在更新？
嗨，我有以下代码来search和search项目显示在列表框中。 我还有一个更新button，可以更新您在文本框中input的任何新信息。 更新框工作正常，但由于某种原因，当多个重复的项目显示在列表框中，我尝试点击第二个实例，并尝试更新，它更新原来的而不是第二个实例。 因此，第一个实例应该更新第一个实例项目，第二个应该更新第二个，但现在，第一个是更新第一个实例，第二个是更新第一个实例，第三个是更新第一个实例 – 总是更新第一个实例。 我怎样才能解决这个问题？ 这是文档： 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 第一个明显的问题是r 。 这个全局variables被Search_Click用作临时variables，而被Search_Click用作主variables。
考虑update_Click 。 接近开始，我们有：
Set ws = ThisWorkbook.Worksheets("Master") With ws Set f = .Cells(r, 1)
如果你加载表单，填写字段并点击更新，那么r将不会被初始化，所以默认值为零。
猜测这个表单试图达到什么是非常困难的。 大多数button什么也不做。 在这两个button上工作，都没有logging。 我很欣赏这个表单正在开发中，但是如果你打算让人们去帮助debugging，那么你应该更容易。
我假设update_Click的目标是添加一个新的行到工作表“Master”的底部。 如果这个假设是真的，那么我build议如下：
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
如果您确认我在正确的轨道上，我看看Search_Click 。
下面的代码与您的实质不同。 部分原因是因为你的代码不工作，而我已经testing过，我的工作。 但大部分的变化是因为我不明白你的代码。 当我通过你的代码工作时，我logging了它，改成了有意义的名字，实现了我以为你试图实现的效果。
在创build代码时，重要的是要记住，在六个或十二个月内，您将回来更新以满足新的要求。 在编写代码时花费一点时间使代码变得容易理解，在需要维护时可以节省数小时的时间。 系统地命名variables，以便您在返回时立即知道它们是什么。 解释每个子程序和代码块试图达到什么目的，以便你可以find你想要更新的代码。
首先，我改变了你的forms。 我已经把表格做得更深一些，并把列表框向下移动。 在列表框的上方，我插入了一个名为lblMessage的标签。 这个标签跨越整个表格的宽度，是三行深的。 大部分文本是Tahoma 8.这个标签是Tahoma 10，并且是蓝色的。 我用它来告诉用户他们应该做什么。
作为表单代码的第一行，我添加了：
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"
这使得我的发言比你的发言时间长得多，但意味着不是5，而是说，我有一个名字。
这些常量是用我的系统命名的。 “上校”说这些是专栏。 “硕士”说他们适用于哪个工作表。 “FamilyName”表示哪一列。 在你的代码中，你使用“姓氏”和“名字”。 我在一个“姓”和“名”不“文化敏感”的地区工作了很多年。 我不是要你喜欢我的系统，但你必须有一个系统。 我可以看看我多年前写的代码，知道variables是什么。
我已经取代你的：
Public r As Long
有：
Dim RowEnteredName() As Long
我重新为每个select这个数组。 如果只有一行匹配input的名称，则它的尺寸为ReDim RowEnteredName(1 To 1) ， RowEnteredName(1)保存行号。 如果计数行匹配input的名称，那么它的尺寸为ReDim RowEnteredName(0 To Count) 。 不使用RowEnteredName(0)因为它对应于标题行，而RowEnteredName(1 To Count)保存每个名称重复的行号。
我已经添加了表单初始化例程来准备表单以供使用。
我将您的findnext重新编码为FillListBox因为您不能使用关键字作为子例程或variables的名称。
你的代码中有一些例程我已经注释掉了，所以我知道下面的代码是完整的。
我希望这一切都是有道理的。
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