swaggerbox
01-02-2020, 04:36 AM
I have a workbook with two sheets. The first sheet ("GUI") is the user interface while the other sheet ("Dic") contains the list of diseases (column A) and its corresponding keyword (column B). The macro below searches the textbox (Textbox1) in Sheet "GUI" to locate any diseases listed in Sheet "DIC" and if it finds a match, displays the diseases in the Listbox where user have option to select what disease is more relevant to him. Once he double clicks the listbox, the adjacent value (the activity keyword) corresponding to the disease is displayed in the output textbox (Textbox2). The format in the output textbox is "keyword" followed by semi-colon and space and then the next keyword entry. Now the macro below does exactly that and prevents any duplicate values to output. However, in cases where there are multiple keywords for particular diseases, e.g. Acne and Actinic keratosis (both with Dermatological as keyword), how do I prevent or remove the duplicate keyword (Dermatological) from appearing? See attached sample workbook
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim Msg As String
Dim t As Integer
Dim lRow As Long
lRow = Sheets("Dic").Range("A65536").End(xlUp).Row
If ActiveSheet.ListBox1.ListIndex = -1 Then
Msg = "Nothing"
Else
Msg = ""
For t = 0 To ActiveSheet.ListBox1.ListCount - 1
If ActiveSheet.ListBox1.Selected(t) Then _
Msg = Msg & ActiveSheet.ListBox1.List(t) '& vbCrLf
Next t
Dim str_accrual As String
Dim rngToSearch As Range
str_accrual = Msg
Set rngToSearch = Sheets("Dic").Range("A1:A" & lRow)
If Not IsError(Application.Match(str_accrual, rngToSearch, 1)) Then
i = Application.Match(str_accrual, rngToSearch, 1)
Var = Sheets("Dic").Range("A" & i).Offset(0, 1)
If InStr(ActiveSheet.TextBox2.Text, Var) > 0 Then
MsgBox "Activity KW already exists"
Else
If ActiveSheet.TextBox2.Text = "" Then
ActiveSheet.TextBox2.Text = Var
Else
ActiveSheet.TextBox2.Text = ActiveSheet.TextBox2.Text & "; " & Var
End If
End If
Else
End If
End If
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim Msg As String
Dim t As Integer
Dim lRow As Long
lRow = Sheets("Dic").Range("A65536").End(xlUp).Row
If ActiveSheet.ListBox1.ListIndex = -1 Then
Msg = "Nothing"
Else
Msg = ""
For t = 0 To ActiveSheet.ListBox1.ListCount - 1
If ActiveSheet.ListBox1.Selected(t) Then _
Msg = Msg & ActiveSheet.ListBox1.List(t) '& vbCrLf
Next t
Dim str_accrual As String
Dim rngToSearch As Range
str_accrual = Msg
Set rngToSearch = Sheets("Dic").Range("A1:A" & lRow)
If Not IsError(Application.Match(str_accrual, rngToSearch, 1)) Then
i = Application.Match(str_accrual, rngToSearch, 1)
Var = Sheets("Dic").Range("A" & i).Offset(0, 1)
If InStr(ActiveSheet.TextBox2.Text, Var) > 0 Then
MsgBox "Activity KW already exists"
Else
If ActiveSheet.TextBox2.Text = "" Then
ActiveSheet.TextBox2.Text = Var
Else
ActiveSheet.TextBox2.Text = ActiveSheet.TextBox2.Text & "; " & Var
End If
End If
Else
End If
End If
End Sub