列表框中只有一個項目正在更新？

Question

嗨我有以下代碼來搜索和搜索項目顯示在列表框中。我還有一個更新按鈕，用於更新您在文本框中輸入的任何新信息。更新框工作正常，但由於某種原因，當多個重複的項目顯示在列表框中，我嘗試點擊第二個實例並嘗試更新時，它更新原始的而不是第二個實例。因此，第一個實例應該更新第一個實例項目，第二個應該更新第二個，但現在，第一個是更新第一個實例，第二個是更新第一個實例，第三個是更新第一個實例 - 總是更新第一個實例。我怎樣才能解決這個問題？這是文檔：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

第一個明顯的問題是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。

Answer 2

以下代碼與您的實際大不相同。部分原因是因爲你的代碼沒有工作，而在我測試過的程度上，我的代碼卻沒有工作。但大部分更改都是因爲我不瞭解您的代碼。當我通過你的代碼工作時，我記錄了它，改成了有意義的名字，並且實現了我以爲你試圖實現的效果。

當您創建代碼時，請務必記住，在六個或十二個月內您將回來更新它以滿足新的要求。花費一點時間使代碼易於理解，在您需要維護時可以節省數小時。系統地命名變量，以便您在返回時立即知道它們是什麼。解釋它試圖實現的每個子程序和代碼塊，以便您可以找到想要更新的代碼。

首先，我改變了你的形式。我將表格做得更深一些，並將列表框向下移動。在列表框的上方，我插入了一個我已經命名爲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」說明哪一列。在你的代碼中你使用「姓氏」和「名字」。我在一個「姓氏」和「名字」不是「文化敏感」的地區工作了很多年。我不是要你喜歡我的系統，但你必須有一個系統。我可以看看我多年前寫的代碼，並知道變量是什麼。

我已經取代你：

Public r As Long 

有：

Dim RowEnteredName() As Long 

我REDIMENSION該數組爲每個選擇。如果只有一行與輸入的名稱相匹配，那麼它的尺寸爲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