обновляется только один элемент в списке?

71
6

Привет, У меня есть следующий код для поиска, и найденные элементы отображаются в списке. У меня также есть кнопка обновления, которая обновляет любую новую информацию, введенную вами в текстовое поле. окно обновления работает нормально, но по какой-то причине, когда в списке отображаются несколько дублированных элементов, и я пытаюсь щелкнуть второй экземпляр и попытаться обновить его, он обновит исходный, а не второй экземпляр. Итак, первый экземпляр должен обновить первый экземпляр, а второй должен обновить второй, но сейчас, 1-й обновляет 1-й экземпляр, 2nd обновляет 1-й экземпляр, третий обновляет 1-й экземпляр - всегда обновляет 1-й экземпляр. Как я могу это исправить? это документ: 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

спросил(а) 2014-02-18T03:35:00+04:00 6 лет, 8 месяцев назад
1
Решение
58

Код ниже существенно отличается от вашего. Отчасти это связано с тем, что ваш код не работал, в то время как, насколько я его протестировал, у меня есть. Но большинство изменений связано с тем, что я не понял ваш код. Когда я работал над вашим кодом, я задокументировал его, изменил на значащие имена и реализовал эффекты, которые, как я думал, вы пытались достичь.

Когда вы создаете код, важно помнить, что через шесть или двенадцать месяцев вы вернетесь, чтобы обновить его для новых требований. Небольшое время, потраченное на то, чтобы сделать код понятным, когда вы его пишете, может сэкономить часы, когда вам нужно его поддерживать. Назовите переменные систематически, чтобы вы сразу узнали, что они собой представляют, когда вернетесь. Объясните, что каждая подпрограмма и блок кода пытаются достичь, чтобы вы могли найти код, который хотите обновить.

Во-первых, я изменил вашу форму. Я сделал форму немного глубже и переместил список. Над списком я вставил ярлык, который я назвал lblMessage. Эта метка охватывает всю ширину формы и имеет три строки глубиной. Большая часть вашего текста - Tahoma 8. Этот ярлык - Tahoma 10 и окрашен в синий цвет. Я использую его, чтобы сообщить пользователю, что они должны делать.

В качестве первой строки кода формы я добавил:

Option Explicit

Посмотрите это выражение, чтобы понять, почему он всегда должен присутствовать.

Вы используете Offsets для доступа к различным столбцам на листе. Это может быть кошмар, если столбцы будут перегруппированы. Я использовал константы:

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

Я перенастраиваю этот массив для каждого выбора. Если только одна строка соответствует введенному имени, то она имеет размер как ReDim RowEnteredName(1 To 1) а RowEnteredName(1) содержит номер строки. Если строки Count соответствуют введенному имени, то он имеет размер как 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 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

ответил(а) 2014-02-21T01:32:00+04:00 6 лет, 8 месяцев назад
58

Первой очевидной проблемой является r. Этот глобальный используется как временная переменная с помощью Search_Click и в качестве основной переменной update_Click.

Рассмотрим update_Click. В начале мы имеем:

Set ws = ThisWorkbook.Worksheets("Master")
With ws
Set f = .Cells(r, 1)

Если вы загрузите форму, заполните поля и нажмите Update , тогда r не будет инициализирован, так что значение по умолчанию будет равным нулю.

Очень сложно догадаться, чего пытается достичь эта форма. Большинство кнопок ничего не делают. Из двух кнопок, которые работают, ни один из них не документирован. Я понимаю, что эта форма находится в разработке, но если вы попросите людей помочь ее отладить, вам следует сделать это проще.

Я предполагаю, что целью update_Click является добавление новой строки в нижнюю часть рабочего листа "Мастер". Если это предположение верно, то я предлагаю следующее:

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.

ответил(а) 2014-02-19T01:20:00+04:00 6 лет, 8 месяцев назад
Ваш ответ
Введите минимум 50 символов
Чтобы , пожалуйста,
Выберите тему жалобы:

Другая проблема