1) unire valori - 2) trovare corrispondenze

Option Explicit

Sub StartProc()
Dim WkDiz As Worksheet, WkTest As Worksheet, urD As Long, urT As Long, r As Integer
Dim i As Long, c As Object, k As Long, k1 As Long, strTmp As String
Dim ToFind As String
'Application.ScreenUpdating = False
On Error GoTo xit
Set WkDiz = Worksheets("Dizionario")
Set WkTest = Worksheets("Testo")
urD = WkDiz.Range("A" & Rows.Count).End(xlUp).Row
urT = WkTest.Range("A" & Rows.Count).End(xlUp).Row

'sort Dizionario
With WkDiz.Sort
    .SortFields.Clear
    .SetRange Range("A1:B" & urD)
    .SortFields.Add Key:=Range("A1") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

k1 = 0 'contatore
'unisce descrizioni dizionario
With WkDiz
    For i = urD To 2 Step -1
        Cells(1, 1) = k1
        k1 = k1 + 1
        If UCase(.Cells(i, 1)) = UCase(.Cells(i - 1, 1)) Then
        .Cells(i - 1, 2) = .Cells(i - 1, 2) & "||" & .Cells(i, 2)
        .Cells(i, 1).EntireRow.Delete
        End If
    Next i
End With

'riporta in Testo descrizioni Dizionario
Worksheets("Testo").Select
r = 2
k = 0
strTmp = ""
For i = r To urT
    Cells(1, 1) = k1
    k1 = k1 + 1
    If Cells(i, 3) <> "" Then
        ToFind = Cells(i, 3)
        With WkDiz.Range("A:A")
            Set c = .Find(ToFind, LookIn:=xlValues, lookat:=xlWhole)
            If Not c Is Nothing Then
                strTmp = strTmp & .Cells(c.Row, 2)
                k = k + 1
            End If
        End With
    End If
    If strTmp <> "" Then Cells(i, 5) = strTmp
    strTmp = ""
Next i
Application.ScreenUpdating = True
MsgBox "Fine elaborazione. Trovati: " & k
cells(1,1)=""
Exit Sub
xit:
MsgBox Err.Number & " - " & Err.Description
Application.ScreenUpdating = True
cells(1,1)=""
End Sub

    For i = 3 To urAp
        If mAp.Cells(i, 1) <> "" Then
            rTo = mAp.Cells(i, 1).Row - 1
            Do Until mAp.Cells(i, 2) = ""
                A2 = A2 & Join(Array(mAp.Cells(i, 2), Chr(2)))
                i = i + 1
            Loop
            A = mTe.Cells(i, 1).Row - 1
            mAp.Cells(rTo, 2).Resize(, A - rTo + 1) = Split(A2, Chr(2))
            mAp.Rows(rTo).Font.Bold = True
            mAp.Cells(rTo, 1) = mAp.Cells(rTo + 1, 1)
            mAp.Cells(rTo + 1, 1) = ""
        End If
        A2 = ""
        mAp.Rows(i).EntireRow.Insert
        i = i + 1
    Next i