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***

1. 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.
2. 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 alto o igual grado de coincidencia? Agradezco su ayuda en el caso en estudio. Saludos