Investigando sobre el tema de la publicación un experto me ayudo con una solución que en mi opinión es acertada, a continuación la comparto en caso de que sea de alguna ayuda para algún integrante de la comunidad,
Option Explicit
Sub buscarSimilitudes()
Dim Celda As Range, Descrip, Mat, Nat, i As Integer, Q As Integer, iTerm, Vector, Rng As Range, j As Integer
Application.ScreenUpdating = False
With Sheets("BD")
Nat = .Range("A2", .Range("B1").End(xlDown))
End With
Q = UBound(Nat)
For i = 1 To Q
iTerm = Split(Nat(i, 2), "(")(0)
Nat(i, 2) = Split(Reemplazos(CStr(iTerm)), " ")
Next
ReDim Preserve Nat(1 To Q, 1 To 3)
For Each Celda In Sheets("Lista").Range("B2", Sheets("Lista").Range("B1").End(xlDown))
Descrip = Split(Reemplazos(Celda.Value), " ")
Mat = Nat
For Each iTerm In Descrip
For i = 1 To Q
j = 0: On Error Resume Next
j = Application.Match(iTerm, Mat(i, 2), 0): On Error GoTo 0
If j > 0 Then
Mat(i, 3) = 1 + Mat(i, 3)
Mat(i, 2)(j - 1) = ""
End If
Next
Next
With CreateObject("System.Collections.ArrayList")
For i = 1 To Q
Mat(i, 3) = 0 + Mat(i, 3)
.Add Format(Mat(i, 3), "000") & "|" & Mat(i, 1)
Next
.Sort
.Reverse
Vector = .toArray
End With
Celda.Offset(, -1) = Split(Vector(0), "|")(1) & " | " & Split(Vector(1), "|")(1) & " | " & Split(Vector(2), "|")(1) & " | " & Split(Vector(3), "|")(1)
Next
Set Rng = Sheets("Lista").Range("A2", Sheets("Lista").Range("A1").End(xlDown))
Rng(Rng.Count).Offset(2).FormulaArray = "=Sum(If( IsError(Search(" & _
Rng(Rng.Count).Offset(3).Address(external:=True) & ", " & _
Rng.Address(external:=True) & ")), False, 1))"
Do
Vector = "NR"
For Each Celda In Rng
For Each iTerm In Split(Celda, " | ")
Rng(Rng.Count).Offset(3) = iTerm
If Rng(Rng.Count).Offset(2) = 1 And UBound(Split(Celda, " | ")) > 0 Then
Celda = iTerm
Vector = "R"
Exit For
End If
Next
Next
Loop Until Vector = "NR"
Rng(Rng.Count).Offset(2).Resize(2).Delete xlShiftUp
Application.ScreenUpdating = True
MsgBox "Proceso terminado."
End Sub
Private Function Reemplazos(t1 As String)
Dim Desde, Hasta, i As Integer
t1 = UCase(t1)
Desde = "ÁÉÍÓÚØ.-:,()"
Hasta = "AEIOUD "
For i = 1 To Len(Desde)
t1 = Replace(t1, Mid(Desde, i, 1), Mid(Hasta, i, 1))
Next
t1 = Replace(t1, """", " ")
Reemplazos = Application.Trim(t1)
End Function
Sub Normalizar()
Dim Rng As Range, Vector, i As Integer, Q As Integer, R As Integer, C As Range, D As Range, Tmp
Set Rng = Range("A2", Range("A1").End(xlDown))
Rng = Evaluate("Transpose(Transpose(Trim(" & Rng.Address & ")))")
Vector = Application.Transpose(Rng): Q = UBound(Vector)
For i = 1 To Q
If InStr(Vector(i), "|") = 0 Then
R = 1 + R: Vector(R) = Vector(i)
End If
Next
If R = 0 Then Exit Sub
ReDim Preserve Vector(1 To R)
For i = 1 To R
Set D = Rng.Find(Vector(i), LookAt:=xlPart, SearchDirection:=xlNext, MatchCase:=False)
Do
If D <> Vector(i) Then D = Join(Filter(Split(D, " | "), Vector(i), False), " | ")
Set C = D
Set D = Rng.FindNext(D)
Loop Until D.Row <= C.Row
Next
MsgBox "Normalización terminada."
End Sub
Proceso macro
- La primera macro (buscarSimilitudes): Busca cada palabra de cada descripción de la hoja Lista en las descripciones de la hoja B y va sumarizando las coincidencias.
- La segunda macro (Normalizar): Procede con la "intervención manual" retirando los códigos únicos de la hoja Lista que se van agregando y disminuyendo las coincidencias finales.
Actualización Post:
Sabiendo este proceso ¿Hay alguna forma de aumentar las coincidencias a partir de una similitud clave como lo son las dimensiones y así tener un igual grado de coincidencia? Agradezco su ayuda en el caso en estudio. Saludos