Removing duplicate from keywords

[swaggerbox]

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

[snb]

Rethink your project: use a Userform with comboboxes.

[swaggerbox]

I think that can be done. How about the duplicates?

[paulked]

You could put the items of the textbox into an array, remove duplicates then re-populate the textbox:



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
'Remove duplicates
Dim aTB2
Dim d As New Scripting.Dictionary ' Reference Microsoft Scripting Runtime in the VBE window.
aTB2 = Split(ActiveSheet.TextBox2.Text, ";")
With d
For i = LBound(aTB2) To UBound(aTB2)
If IsMissing(aTB2(i)) = False Then
.Item(aTB2(i)) = 1
End If
Next
ActiveSheet.TextBox2.Text = Join(.Keys, ";")
End With
End Sub

[swaggerbox]

you did it again paul. cant thank you enough.

[paulked]

You're welcome :thumb

[Paul_Hossler]

you did it again paul. cant thank you enough.

And quickly too


I was doing the same basic thing without a dictionary object and paulked beat me :thumb

[paulked]

I have to thank snb's website for teaching me arrays :clap:

[snb]

You can do this in 1 go:


Private Sub CommandButton1_Click()
sn = Sheet1.Cells(1).CurrentRegion
c00 = Sheet2.TextBox1

For j = 1 To UBound(sn)
If Len(Replace(c00, sn(j, 1), "", , , 1)) <> Len(c00) Then
c01 = c01 & sn(j, 1) & vbLf
If InStr(c02, sn(j, 2)) = 0 Then c02 = c02 & ";" & sn(j, 2)
End If
Next

Sheet2.ListBox1.List = Split(c01, vbLf)
Sheet2.TextBox2.Text = Mid(c02, 2)
End Sub

[swaggerbox]

you make it so simple snb. thanks

[snb]

An alternative, using strcomp:


Private Sub CommandButton1_Click()
sn = Sheet1.Cells(1).CurrentRegion
c00 = Sheet2.TextBox1

For j = 1 To UBound(sn)
If StrComp(Replace(c00, sn(j, 1), "", , , 1), c00, 1) <> 0 Then
c01 = c01 & sn(j, 1) & vbLf
If InStr(c02 & ";", Replace(";~;", "~", sn(j, 2))) = 0 Then c02 = c02 & ";" & sn(j, 2)
End If
Next

Sheet2.ListBox1.List = Split(c01, vbLf)
Sheet2.TextBox2.Text = Mid(c02, 2)
End Sub