Private Sub ListBox1_AfterUpdate()
Dim rs As Object
Set rs = Me.Recordset.Clone
rs.FindFirst "[Item ID] = " & str(Nz(Me![ListBox1], 0))
If Not rs.EOF Then Me.Bookmark = rs.Bookmark
Dim l As Long, X As Long, a$
Dim Strg As String
Dim StrgArray() As String
Dim Source As String
Me.Text152 = ""
Source = Trim(Me.Text150): X = 0
For l = 1 To Len(Source)
a$ = Mid$(Source, l, 1)
If a$ = Chr$(10) Then GoTo Cont1
If a$ = Chr$(13) Then
ReDim Preserve StrgArray(X)
StrgArray(X) = Strg
X = X + 1
Strg = "": a$ = ""
GoTo Cont1
End If
Strg = Strg & a$
Cont1:
Next l
If Strg <> "" Then
ReDim Preserve StrgArray(X)
StrgArray(X) = Strg
Strg = "": a$ = ""
End If
Dim j As Long, Hit As Boolean, k As Integer
Dim StrgArrayTmp() As String, Hit2 As Integer
k = 0
For i = 0 To UBound(StrgArray)
a$ = StrgArray(i)
On Error Resume Next
For j = 0 To UBound(StrgArrayTmp)
If Err <> 0 Then GoTo ByPass
If a$ = Left$(StrgArrayTmp(j), Len(a$)) Then Hit = True: Exit For
Next j
If Err <> 0 Then Err = 0
On Error GoTo 0
ByPass:
If Hit = True Then
Hit = False
a$ = ""
GoTo Cont2
End If
For X = 0 To UBound(StrgArray)
If a$ = StrgArray(X) Then Hit2 = Hit2 + 1
Next X
ReDim Preserve StrgArrayTmp(k)
StrgArrayTmp(k) = a$ & "(" & Hit2 & ")" & vbNewLine
k = k + 1: Hit2 = 0
Cont2:
Next i
On Error Resume Next
For i = 0 To UBound(StrgArrayTmp)
Me.Text152 = Me.Text152 & StrgArrayTmp(i)
Next i
Erase StrgArray, StrgArrayTmp
End Sub