VBA Lookup Value and report in msg box and change value in cell on same row

user_15344193 0
Viewed 229

I am trying to have a userform search a worksheet for the specific specimen_ID (column AV) and report back items in Columns (T, S, and W). Preferably, these items would show up in a message box after clicking verify patient info (command button). If these match on the physical test item, then the user would need to update the test result from a Combobox which updates info in column AS.

I'm having difficulty finding the correct coding to use. I initially thought to just have the verified patient info pop-up as a message box instead of using text boxes, but I wasn't sure how to input match and index functions into the VBA coding. And I also am not sure how to use match/index in this scenario. I know that Vlookup only works when searching to the right.

Example workbook with the VBA user forms and coding https://www.filedropper.com/dummytest

Here's the whole code for that user form.

Private Sub CBResult_Enter()
Me.CBResult.Clear
Me.CBResult.AddItem "Detected/Positive"
Me.CBResult.AddItem "Not detected/Negative"
Me.CBResult.AddItem "Inconclusive/Undetermined/Invalid/Equivocal"
End Sub

Private Sub CmdB_Results_Verify_Click()

Dim specimen_id As String
specimen_id = Trim(Txt_Results_SpecimenID.Text)

lastrow = Worksheets("Entry").Cells(Rows.Count, "AV").End(xlUp).Row

For i = 2 To lastrow
If Worksheets("Entry").Cells(i, 1).Value = specimen_id Then
Txt_Results_FName = Worksheets("Entry").Cells(i, "T").Value
Txt_Results_LName = Worksheets("Entry").Cells(i, "S").Value
Txt_Results_DOB = Worksheets("Entry").Cells(i, "W").Value

End If
Next

End Sub

Private Sub CmdBResult_Save_Click()

'copy values to sheet.
Dim Result As String
Result = CBResult.Value
lastrow = Worksheets("Entry").Cells(Rows.Count, "AV").End(xlUp).Row

For i = 2 To lastrow
If Worksheets("Entry").Cells(i, 1).Value = Txt_Results_specimen_id.Value Then
Worksheets("Entry").Cells("AS").Value = CBResult.Value

'Clear input Controls.

Me.CBResult.Value = ""
Txt_Results_FName.Value = ""
Txt_Results_LName.Value = ""
Txt_Results_DOB.Value = ""

End Sub

Private Sub CmdB_Results_Close_Click()
'Close "ResultsEntry"
Unload Me
End Sub

The fewer text boxes I have here the better.

userform vba excel
1 Answers

I have updated your code to do what I believe you are wanting. I will paste the entire code so you can just put the whole thing back into your userform code.

Please note:

  • I have added to the specimen ID that it will only accept numeric values. This is because if it is a string it won't find a match as the specimen ID's are numbers. Numbers and strings are treated differently in VBA.
  • You weren't updating your save button (when it would work) as you had your sub as: Private Sub CmdBResult_Save_Click() when it should've been this: Private Sub CmdB_Results_Save_Click()
  • I added some message boxes for certain events. You can obviously edit what they say or remove them if you don't want them.
  • I used Application.Match to find the match instead of looping. This will work should there only be one match you need to update. If you need to for some reason find duplicates etc then it would need to change to use either .Find or loop.
  • I put FindResult as a public variable so that the Specimen ID doesn't have to be found twice (once to get the patient details and again to update the test result).

Let me know if there is something wrong with it but it should work. I've tested it all.

Public FindResult As Double

Private Sub CBResult_Enter()
Me.CBResult.Clear
Me.CBResult.AddItem "Detected/Positive"
Me.CBResult.AddItem "Not detected/Negative"
Me.CBResult.AddItem "Inconclusive/Undetermined/Invalid/Equivocal"
End Sub

Private Sub CmdB_Results_Verify_Click()

Dim specimen_id As Double

'Check something has been enetered in SpecimenID
If Len(Txt_Results_SpecimenID.Text) = 0 Then
    Exit Sub
End If
FindResult = 0
specimen_id = Txt_Results_SpecimenID.Text

On Error Resume Next
FindResult = Application.Match(specimen_id, Sheets("Entry").Range("AV:AV"), 0) 'Find the matching ID

If FindResult > 0 Then 'FindResult will be greater than 0 if match found. It will be the row that it found it on.
    Txt_Results_FName.Text = Worksheets("Entry").Range("T" & FindResult).Value
    Txt_Results_LName.Text = Worksheets("Entry").Range("S" & FindResult).Value
    Txt_Results_DOB.Text = Worksheets("Entry").Range("W" & FindResult).Value
Else
    MsgBox "No matching Specimen ID was found.", vbInformation, "No Result"
    Me.CBResult.Value = ""
    Txt_Results_FName.Value = ""
    Txt_Results_LName.Value = ""
    Txt_Results_DOB.Value = ""
End If

End Sub

Private Sub CmdB_Results_Save_Click()

'copy values to sheet.
Dim Result As String

If Len(Txt_Results_SpecimenID.Text) = 0 Then
    MsgBox "There is no Specimen ID entered. The patient info cannot be updated without this identifier.", vbExclamation, "Please enter Specimen ID"
    Exit Sub
ElseIf FindResult = 0 Then
    MsgBox "The Specimen ID has not been searched for. Please do this before trying to update the patient info.", vbExclamation, "Please enter Specimen ID"
    Exit Sub
ElseIf CBResult.Value = "" Then
    MsgBox "Please select a test result from the options.", vbExclamation, "Select a test result"
    Exit Sub
End If


Worksheets("Entry").Range("AS" & FindResult).Value = CBResult.Value

'Clear input Controls.
Me.CBResult.Value = ""
Txt_Results_FName.Value = ""
Txt_Results_LName.Value = ""
Txt_Results_DOB.Value = ""

End Sub

Private Sub CmdB_Results_Close_Click()

'Close "ResultsEntry"
Unload Me

End Sub

Private Sub Txt_Results_SpecimenID_Change()

Dim ID As String
ID = Txt_Results_SpecimenID.Text

'This will only allow numbers to be entered into the Specimen ID box
If Not IsNumeric(Right(ID, 1)) Then
    If Len(ID) = 0 Then Exit Sub
    Txt_Results_SpecimenID.Text = Left(ID, Len(ID) - 1)
End If

End Sub
user_26321650
Related