您好我有以下代码要搜索，搜索的项目会显示在列表框中。我还有一个更新按钮，可以更新您在文本框中输入的任何新信息。更新框工作正常但由于某种原因，当列表框中显示多个重复项目，我尝试单击第二个实例并尝试更新，它更新原始而不是第二个实例。因此，第一个实例应该更新第一个实例项，第二个应该更新第二个但是现在，第一个是更新第一个实例，第二个是更新第一个实例，第三个是更新第一个实例 - 总是更新第一个实例。我怎样才能解决这个问题？这是文件：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
答案 0 :(得分：1)
第一个明显的问题是r。此全局用作Search_Click的临时变量和update_Click的主变量。
考虑update_Click。在一开始我们有：
Set ws = ThisWorkbook.Worksheets("Master")
With ws
Set f = .Cells(r, 1)
如果您加载表单，请填写字段并单击更新，然后r将不会被初始化，因此默认值为零。
很难猜出这种形式试图实现的目标。大多数按钮什么都不做。在两个有效的按钮中，都没有记录。我很欣赏这个表单正在开发中，但是，如果你要求人们帮助调试它，你应该更容易这样做。
我假设update_Click的目标是在工作表“Master”的底部添加一个新行。如果这个假设是真的那么我建议如下：
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。
答案 1 :(得分：1)
以下代码与您的代码有很大不同。部分原因是因为你的代码不起作用，而在我测试过的程度上，我的代码不行。但大多数更改都是因为我不理解您的代码。当我处理你的代码时，我记录了它，改成了有意义的名字并实现了我认为你想要实现的效果。
在创建代码时，请务必记住，在六到十二个月内，您将返回更新代码以满足新要求。花一点时间使代码在编写时易于理解，可以在需要维护代码时节省数小时。系统地命名变量，以便您在返回时立即知道它们是什么。解释它试图实现的每个子例程和代码块，以便找到要更新的代码。
首先我改变了你的表格。我已经使表单更深一些，并将列表框向下移动。在列表框上方，我插入了一个名为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，比方说，我有一个名字。
这些常量使用我的系统命名。 “Col”说这些是专栏。 “Master”说明了他们适用的工作表。 “FamilyName”表示哪一列。在您的代码中，您使用“姓氏”和“名字”。我在“姓”和“名字”不是“文化敏感”的地区工作了很多年。我不是要求你喜欢我的系统，但你必须有一个系统。我可以看一下几年前写的代码，知道变量是什么。
我已经取代了你的：
Public r As Long
使用：
Dim RowEnteredName() As Long
我为每个选择重新定义此数组。如果只有一行与输入的名称匹配，则其标注为ReDim RowEnteredName(1 To 1)，RowEnteredName(1)保存行号。如果计数行与输入的名称匹配，则其标注为ReDim RowEnteredName(0 To Count)。未使用RowEnteredName(0)，因为它对应于标题行，而RowEnteredName(1 To Count)包含每次重复名称的行号。
我已添加表单初始化例程以准备表单以供使用。
我已将findnext重新编号为FillListBox，因为您无法使用关键字作为子程序或变量的名称。
我已经注释了您的代码中的例程，以便我知道下面的代码已经完成。
我希望这一切都有道理。
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