Actualizacion Post
Continuando la indagacion sobre el tema un gran experto en VBA y excel me ayudo con esta solucion que es la definitiva y concluye el post,
La propuesta, maneja los arreglos en memoria, crea índices por cada
componente, ejemplo: "tee", "brida", "buje", "codo", "etc".
Además creará un índice de cada palabra para cada componente, de tal
manera que se tendra un índice por componente:
"1.Tee-tuberia", "1.tee-acero", "1.tee-etc"
"2.Tee-pvc", "2.tee-presion", "2.tee-etc"
Nota: la macro considera cuando existe más dimensiones o palabras iguales, ejemplo:
Unión de acople rígido para tubería acero galvanizado, unión roscada con D= 2"-2"
Option Explicit
Sub CompararCoincidencias()
'
Dim sh1 As Worksheet
Dim a As Variant, b As Variant, C As Variant
Dim dic As Object, dic1 As Object, dic2 As Object
Dim i As Long, j As Long, k As Long, n As Long, m As Long, x As Long, y As Long
Dim fil As Long, col As Long, nmax As Long
Dim desc As String, palabra As Variant, palabra2, izq As String
Dim w1 As String, tema As String, codigo As String
Set sh1 = Sheets("BD")
Set dic = CreateObject("Scripting.Dictionary")
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
a = sh1.Range("A2", sh1.Range("B" & Rows.Count).End(3)).Value
b = Sheets("Lista").Range("A2", Sheets("Lista").Range("B" & Rows.Count).End(3)).Value
ReDim C(1 To UBound(a, 1), 1 To UBound(a, 1))
k = 4
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
'Acomodar cada palabra en su correspondiente componente en su fila - columna
For i = 1 To UBound(a, 1)
w1 = limpia(Left(a(i, 2), InStr(1, a(i, 2), " ") - 1))
fil = Split(dic1(w1), "|")(0)
col = Split(dic1(w1), "|")(1) - 1
'cuenta en número de componentes iguales
For x = 1 To col
If Split(C(fil, x), "|")(1) <> "" Then
C(fil, x) = Split(C(fil, x), "|")(0) & "|" & ""
Exit For
End If
Next
'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 Len(palabra) > 3 And Right(palabra, 2) = "da" Then
palabra = Left(palabra, Len(palabra) - 1) & "o"
End If
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
'cuenta el número de veces que se repite una palabra
m = dic(tema)(palabra)
m = m + 1
dic(tema)(palabra) = m
palabra = palabra & "|" & m
Set dic(tema)(palabra) = CreateObject("Scripting.Dictionary")
dic(tema)(palabra) = Empty
Next palabra
End If
' sh1.Cells(1, k).Value = tema
' sh1.Cells(2, k).Resize(dic(tema).Count).Value = Application.Transpose(dic(tema).keys)
' sh1.Cells(2, k + 1).Resize(dic(tema).Count).Value = Application.Transpose(dic(tema).items)
' k = k + 2
Next i
'
'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
n = 0
tema = fil & "|" & x & "|" & w1
y = 0
dic2.RemoveAll
For Each palabra In Split(desc, " ")
If Len(palabra) > 3 And Right(palabra, 2) = "da" Then
palabra = Left(palabra, Len(palabra) - 1) & "o"
End If
'cuenta las palabras que coinciden
m = dic(tema)(palabra)
If dic(tema).exists(palabra) Then
dic2(palabra) = dic2(palabra) + 1
y = dic2(palabra)
palabra2 = palabra & "|" & y
If dic(tema).exists(palabra2) Then
n = n + 1
End If
End If
Next palabra
If n > nmax Then
nmax = n
codigo = Split(C(fil, x), "|")(0)
End If
Next x
End If
If codigo <> "" Then b(i, 1) = codigo
Next i
Sheets("Lista").Range("A2").Resize(UBound(b, 1)).Value = b
'
'Limpiar variables
Set sh1 = Nothing
Set dic = Nothing: Set dic1 = Nothing:: Set dic2 = Nothing
Erase a, b, C
End Sub
Function limpia(texto As Variant) As String
Dim cad As String, cad2 As String, s As Integer
Dim i As Long
'
cad = LCase(texto)
Const r1 = "áéíóúüñ"
Const s1 = "aeiouun"
Const r2 = ",.;:-_=Ø+*<>!¡#$%&'()\¿?[]{}~|°"""""
'
'reemplaza acentos
For i = 1 To Len(r1)
cad = Replace(cad, Mid(r1, i, 1), Mid(s1, i, 1))
Next
'reemplaza caracteres por espacio
For i = 1 To Len(r2)
cad = Replace(cad, Mid(r2, i, 1), " ")
Next
'reemplaza Ø por espacio
cad = Replace(cad, Chr ( 248 ) , " ")
'reemplaza espacios seguidos por un solo espacio
cad = Replace(Replace(Replace(Trim(cad), " ", " "), " ", " "), " ", " ")
limpia = cad
End Function
Espero este post le sea de mucha ayuda a muchas mas personas. Saludos
Para terminar: "El que no vive para servir, no sirve para vivir" Santa Teresa de Calculta