Teams

1. no usa ActiveX
2. no usa Scripting.Dictionary

Option Explicit

Public Sub CruzarNombres_EC_vs_Plantilla()
    Dim wsEC As Worksheet, wsPl As Worksheet
    Dim lastEC As Long, lastPl As Long
    Dim i As Long, j As Long
    Dim keyEC As String, keyPl As String
    Dim nombre As String
    Dim encontrado As Boolean

    Set wsEC = ThisWorkbook.Worksheets("EC")
    Set wsPl = ThisWorkbook.Worksheets("Plantilla")

    lastEC = wsEC.Cells(wsEC.Rows.Count, "C").End(xlUp).Row
    lastPl = wsPl.Cells(wsPl.Rows.Count, "C").End(xlUp).Row

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    For i = 2 To lastEC
        nombre = wsEC.Cells(i, "C").Value2

        If Len(Trim$(nombre)) = 0 Then
            wsEC.Cells(i, "B").Value = ""
        Else
            keyEC = CanonicalName(nombre)
            encontrado = False

            For j = 2 To lastPl
                nombre = wsPl.Cells(j, "C").Value2

                If Len(Trim$(nombre)) > 0 Then
                    keyPl = CanonicalName(nombre)

                    If keyEC = keyPl Then
                        wsEC.Cells(i, "B").Value = wsPl.Cells(j, "B").Value2
                        encontrado = True
                        Exit For
                    End If
                End If
            Next j

            If Not encontrado Then
                wsEC.Cells(i, "B").Value = ""
            End If
        End If
    Next i

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "Cruce terminado"
End Sub

Private Function CanonicalName(ByVal s As String) As String
    Dim t As String, arr As Variant, i As Long
    Dim words() As String, n As Long

    t = UCase$(Trim$(s))
    t = Replace(t, vbCr, " ")
    t = Replace(t, vbLf, " ")
    t = RemoveAccents(t)

    t = Replace(t, ".", " ")
    t = Replace(t, ",", " ")
    t = Replace(t, "-", " ")
    t = Replace(t, "_", " ")

    Do While InStr(t, "  ") > 0
        t = Replace(t, "  ", " ")
    Loop

    If Len(t) = 0 Then
        CanonicalName = ""
        Exit Function
    End If

    arr = Split(t, " ")

    ReDim words(0 To UBound(arr))
    n = 0

    For i = LBound(arr) To UBound(arr)
        If Len(arr(i)) > 0 Then
            If Not IsStopWord(arr(i)) Then
                words(n) = arr(i)
                n = n + 1
            End If
        End If
    Next i

    If n = 0 Then
        CanonicalName = ""
        Exit Function
    End If

    ReDim Preserve words(0 To n - 1)
    QuickSort words, LBound(words), UBound(words)

    CanonicalName = Join(words, "|")
End Function

Private Function IsStopWord(ByVal w As String) As Boolean
    Select Case w
        Case "DE", "DEL", "LA", "LAS", "LOS", "Y"
            IsStopWord = True
        Case Else
            IsStopWord = False
    End Select
End Function

Private Function RemoveAccents(ByVal s As String) As String
    s = Replace(s, "Á", "A")
    s = Replace(s, "À", "A")
    s = Replace(s, "Ä", "A")
    s = Replace(s, "Â", "A")
    s = Replace(s, "á", "A")
    s = Replace(s, "à", "A")
    s = Replace(s, "ä", "A")
    s = Replace(s, "â", "A")

    s = Replace(s, "É", "E")
    s = Replace(s, "È", "E")
    s = Replace(s, "Ë", "E")
    s = Replace(s, "Ê", "E")
    s = Replace(s, "é", "E")
    s = Replace(s, "è", "E")
    s = Replace(s, "ë", "E")
    s = Replace(s, "ê", "E")

    s = Replace(s, "Í", "I")
    s = Replace(s, "Ì", "I")
    s = Replace(s, "Ï", "I")
    s = Replace(s, "Î", "I")
    s = Replace(s, "í", "I")
    s = Replace(s, "ì", "I")
    s = Replace(s, "ï", "I")
    s = Replace(s, "î", "I")

    s = Replace(s, "Ó", "O")
    s = Replace(s, "Ò", "O")
    s = Replace(s, "Ö", "O")
    s = Replace(s, "Ô", "O")
    s = Replace(s, "ó", "O")
    s = Replace(s, "ò", "O")
    s = Replace(s, "ö", "O")
    s = Replace(s, "ô", "O")

    s = Replace(s, "Ú", "U")
    s = Replace(s, "Ù", "U")
    s = Replace(s, "Ü", "U")
    s = Replace(s, "Û", "U")
    s = Replace(s, "ú", "U")
    s = Replace(s, "ù", "U")
    s = Replace(s, "ü", "U")
    s = Replace(s, "û", "U")

    s = Replace(s, "Ñ", "N")
    s = Replace(s, "ñ", "N")

    RemoveAccents = s
End Function

Private Sub QuickSort(ByRef arr() As String, ByVal first As Long, ByVal last As Long)
    Dim i As Long, j As Long
    Dim pivot As String, tmp As String

    i = first
    j = last
    pivot = arr((first + last) \ 2)

    Do While i <= j
        Do While arr(i) < pivot
            i = i + 1
        Loop
        Do While arr(j) > pivot
            j = j - 1
        Loop
        If i <= j Then
            tmp = arr(i)
            arr(i) = arr(j)
            arr(j) = tmp
            i = i + 1
            j = j - 1
        End If
    Loop

    If first < j Then QuickSort arr, first, j
    If i < last Then QuickSort arr, i, last
End Sub