Devolver valor según comparación de listas de texto formulado

Con este arreglo que me ayudaron a realizar se logró hacer que la macro comparara similitudes sin tener en cuenta mayúsculas o minúsculas y acentos, aun asi el codigo compara letra por letra en el mismo orden y ubicación de la frase confrontada, haciendo falta comparar el resto de la frase, me gustaría me ayudaran comparando la frase teniendo en cuenta que hay una columna adicional con la dimensión (Size) de la descripción el cual podría ser el diferenciador que en conjunto encontrará la similitud completa de la descripción con la BD para así devolver el valor Código de la hoja BD a la hoja Lista, agradezco su ayuda.

Sub highlight()
    Dim xRg1 As Range
    Dim xRg2 As Range
    Dim xTxt As String
    Dim xCell1 As Range
    Dim xCell2 As Range
    Dim i As Long
    Dim J As Integer
    Dim xLen As Integer
    Dim xDiffs As Boolean
    Dim tempCell1, tempCell2 As String
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
      xTxt = ActiveSheet.UsedRange.AddressLocal
    End If
lOne:
    Set xRg1 = Application.InputBox("Range A:", "ML1", xTxt, , , , , 8)
    If xRg1 Is Nothing Then Exit Sub
    If xRg1.Columns.Count > 1 Or xRg1.Areas.Count > 1 Then
        MsgBox "Multiple ranges or columns have been selected ", vbInformation, "ML1"
        GoTo lOne
    End If
lTwo:
    Set xRg2 = Application.InputBox("Range B:", "ML1", "", , , , , 8)
    If xRg2 Is Nothing Then Exit Sub
    If xRg2.Columns.Count > 1 Or xRg2.Areas.Count > 1 Then
        MsgBox "Multiple ranges or columns have been selected ", vbInformation, "ML1"
        GoTo lTwo
    End If
    If xRg1.CountLarge <> xRg2.CountLarge Then
       MsgBox "Two selected ranges must have the same numbers of cells ", vbInformation, "ML1"
       GoTo lTwo
    End If
    xDiffs = (MsgBox("Click Yes to highlight similarities, click No to highlight differences ", vbYesNo + vbQuestion, "ML1") = vbNo)
    Application.ScreenUpdating = False
    xRg2.Font.ColorIndex = xlAutomatic
    For i = 1 To xRg1.Count
        Set xCell1 = xRg1.Cells(i)
        Set xCell2 = xRg2.Cells(i)
        'Convertimos la cadena a minúsculas
        tempCell1 = LCase(xCell1.Value2)
        tempCell2 = LCase(xCell2.Value2)
        'Strip accents
        tempCell1 = stripAccent((tempCell1))
        tempCell2 = stripAccent((tempCell2))
        If tempCell1 = tempCell2 Then
            If Not xDiffs Then xCell2.Font.Color = vbRed
        Else
            xLen = Len(xCell1.Value2)
            For J = 1 To xLen
                If Not Mid(tempCell1, J, 1) = Mid(tempCell2, J, 1) Then Exit For
                'If Not LCase(xCell1.Characters(J, 1).Text) = LCase(xCell2.Characters(J, 1).Text) Then Exit For
            Next J
            If Not xDiffs Then
                If J <= Len(xCell2.Value2) And J > 1 Then
                    xCell2.Characters(1, J - 1).Font.Color = vbRed
                End If
            Else
                If J <= Len(xCell2.Value2) Then
                    xCell2.Characters(J, Len(xCell2.Value2) - J + 1).Font.Color = vbRed
                End If
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub
Function stripAccent(Text As String) As String
    Const AccChars = "šžàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
    Const RegChars = "szaaaaaaceeeeiiiidnooooouuuuyy"
    Dim A As String * 1
    Dim B As String * 1
    Dim i As Integer
    For i = 1 To Len(AccChars)
        A = Mid(AccChars, i, 1)
        B = Mid(RegChars, i, 1)
        Text = Replace(Text, A, B)
    Next
    stripAccent = Text
End Function

Continuando con mi analogía:

Imagina que tienes una biblioteca. En la biblioteca tienes los siguientes temas y número de libros

Física 4 libros

Química 5 libros

Biología 3 libros

Matemáticas 8 libros

Y te piden buscar la palabra "roca" en todos los libros.

Entonces tendrías que buscar "roca" en 20 libros, probablemente aparezca en 3 temas: Física, Química y Biología. Y tal vez aparezca en varios libros.

Pero si te piden buscar la palabra "roca" en Química, entonces solamente buscarías en 5 libros.

----

Entonces si creamos índices para cada libro.

Un índice para cada tema de cada libro.

Y un índice para cada palabra de cada libro.

Cuando busques Química-Roca, el índice te llevará directamente a un solo libro.

----

La siguiente propuesta, además de manejar los arreglos en memoria, creará índices para cada componente, ejemplo: "tee", "brida", "buje", "codo", "etc".

Además creará un índice de cada palabra para cada componente, de tal manera que tendrás un índice para componente:

"1.Tee-tuberia", "1.tee-acero", "1.tee-etc"

"2.Tee-pvc", "2.tee-presion", "2.tee-etc"

-------

Voy a explicar esta parte del código:

  For i = 1 To UBound(a, 1)
    w1 = limpia(Left(a(i, 2), InStr(1, a(i, 2), " ") - 1))
    'Crea un índice para cada componente
    If Not dic1.exists(w1) Then
      fil = fil + 1
      col = 1
      dic1(w1) = fil & "|" & col
    End If
    'asigna una fila y una columna para guardar el componente en el arreglo 'c'
    fil = Split(dic1(w1), "|")(0)
    col = Split(dic1(w1), "|")(1)
    c(fil, col) = a(i, 1) & "|" & "#"
    col = col + 1
    dic1(w1) = fil & "|" & col
  Next

Lo que hace es almacenar en un índice 'dic1' cada uno de los temas o componentes:

 "tee", "brida", "buje", "codo", "etc"

Si revisan la instrucción: dic1(w1) = fil & "|" & col, agrega la palabra 'w1' al índice dic1;  y como item,  agrega una fila y una columna.

Ahora veamos, cómo crear un índice de índices, en otras palabras, crear un índice para cada "subtema", en este caso, un índice para cada palabra.

Ejemplo:

Para estas descripciones:

'"TEE para tubería de acero galvanizado tipo EMT"
'"TEE PVC - Presión SCH 40, unión soldada"

Siguiendo la analogía de los libros tendríamos un índice de esta manera:

'Descripción    Índice
'tee            1.1
'  para         1.1.1
'  tuberia      1.1.2
'  de           1.1.3
'  acero        1.1.4
'  galvanizado  1.1.5
'  tipo         1.1.6
'  emt          1.1.7
'tee            1.2
'  pvc          1.2.1
'  presion      1.2.2
'  sch          1.2.3
'  40           1.2.4
'  union        1.2.5
'  soldada      1.2.6

En el código:

    'CREA LOS TEMAS, con fila y columna
    tema = fil & "|" & x & "|" & w1
    If Not dic.exists(tema) Then
      Set dic(tema) = CreateObject("Scripting.Dictionary")
      izq = Left(a(i, 2), InStr(1, a(i, 2), "(") - 1)
      desc = limpia(izq)
      m = 0
      'AGREGA cada palabra a un indice dentro de cada tema
      For Each palabra In Split(desc, " ")
        If Not dic(tema).exists(palabra) Then
          'AGREGA la primer palabra en el TEMA
          Set dic(tema)(palabra) = CreateObject("Scripting.Dictionary")
          dic(tema)(palabra) = 0
        End If

Analicemos la primer línea:

tema = fil & "|" & x & "|" & w1

Se crea la referencia fila - columna - tema, en el ejemplo:

'  sch          1.2."tee"

Fila 'fil', el "1", porque pertenece a la palabra "tee", fue el primer índice creado en el diccionario 'dic1'. Y se le asignó la fila 1.

'  sch          1.2."tee"

Columna 'x', para cada tema "tee" se le asigna una columna, ya que es el mismo componente pero contiene otras palabras.

'  sch          1.2."tee"

Y  por último, w1 es el tema "tee", entonces se crea un índice con el valor: 

'  sch          1.2."tee"

Set dic(tema) = CreateObject("Scripting.Dictionary")

Ahora bien, dentro del índice '  sch          1.2."tee", se va a crear un índice para cada palabra, ejemplo:

'  sch          1.2.3

Set dic(tema)(palabra) = CreateObject("Scripting.Dictionary")

Entonces, si yo quieres saber si existe la palabra "sch" en la biblioteca, no tienes que buscar libro por libro, hoja por hoja, eso sería un proceso muuuuuuuy lento.

Lo que haces, es buscar por tema. "tee".

Con eso, ya tienes identificado que existen 2 líneas con el tema "tee":

'"TEE para tubería de acero galvanizado tipo EMT"
'"TEE PVC - Presión SCH 40, unión soldada"

En el código:

  'Busca cada palabra, de cada fila, de la hoja "Lista" en los temas
  For i = 1 To UBound(b, 1)
    w1 = limpia(Left(b(i, 2), InStr(1, b(i, 2), " ") - 1))
    desc = limpia(b(i, 2))
    codigo = ""
    If dic1.exists(w1) Then
      fil = Split(dic1(w1), "|")(0)
      col = Split(dic1(w1), "|")(1) - 1
      nmax = 0
      For x = 1 To col

Lo que hace es obtener la fila de la palabra tee en el diccionario dic1, el resultado es 1.

Obtener el número de columnas o temas tee, el resultado es 2.

Con esos 2 datos, el tema "tee" y la palabra "sch", obtienes el índice, el resultado es 1,2,"tee","sch"

Si buscas el índice 1,2,"tee","sch" en la primera descripción te regresa que no existe.

Si buscas el índice 1,2,"tee","sch" en la segunda descripción te regresa que sí existe, entonces lo cuentas.

        tema = fil & "|" & x & "|" & w1
        For Each palabra In Split(desc, " ")
          If dic(tema).exists(palabra) Then
            'cuenta las palabras que coinciden
            Dic2(palabra) = dic2(palabra) + 1

Lo que estás haciendo con el índice de palabras es directamente revisar si existe o no existe, no tienes que recorrer cada palabra de la descripción y comparar. Por ejemplo en esta descripción:

'"TEE para tubería de acero galvanizado tipo EMT"

Si tienes la descripción en una matriz, tendrías que comparar una por una: "tee" = "sch", "para" = "sch", "tuberia" = "sch", "de" = "sch" , "acero" = "sch", "galvanizado" = "sch", "tipo" = "sch", "emt" = "sch"; 8 comparaciones. O hacer un match en la misma matriz o un find si lo tienes en la hoja. Haciendo el proceso todavía más lento.

Si representamos cómo estarían los índices en memoria de nuestro ejemplo, sería algo como esto:

Tema: 1,2,"tee"

Palabra: "sch"

En resumen, con estas instrucción creas el índice de la palabra y revisas si existe:

Crear:
Set dic(tema)(palabra) = CreateObject("Scripting.Dictionary")
Buscar:
If dic(tema).exists(palabra) Then

Es una manera más eficiente y rápida, en este caso de realizar la búsqueda.

[