Search code examples
excelvbauserform

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


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.


Solution

  • 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