1

Lo que quiero es que el rango de la columna B de la hoja Lista busque uno a uno sus valores en el rango de la columna B de la hoja BD la coincidencia más acercada a la descripción, teniendo como diferenciador las dimensiones, las cuales se pueden separar de la cadena para ser un diferenciador clave en caso de ser requerido y que cuando encuentre esta coincidencia devuelva el valor de la columna A de la hoja BD a la hoja Lista.

He trabajado en este código con la ayuda de expertos de la comunidad, pero no la he hecho funcionar, cualquier ayuda que me presten es bien recibida. gracias

Sub Coincidencias_Range()

  Dim Range0, Range1, Range2 As Range
  Dim Array1, Array2 As Variant
  Dim TempArray1, TempArray2 As String
  Dim Uf, i, j, k As Long

  
  Uf1 = Range("B1").End(xlDown).Row
  Uf2 = Range("B1").End(xlDown).Row
  
  With ThisWorkbook.Worksheets(1)
        Range1 = .Range("B1:B" & Uf1)
  End With
  
  With ThisWorkbook.Worksheets(2)
        Range2 = .Range("B1:B" & Uf2)
  End With
  
  For k = 1 To Uf1
  
  Array1 = Range1.Cells(k)
  Array2 = Range2.Cells(k)
  
      
  'Convertimos la cadena a minúsculas
  
  TempArray1 = LCase(Array1.Value)
  TempArray2 = LCase(Array2.Value)
  
  TempArray1 = stripAccent((TempArray1))
  TempArray2 = stripAccent((TempArray2))
  
  Dim LoopCol As Long
  Dim LoopCol2 As Long
  
 For i = 1 To Uf
    For LoopCol2 = 1 To Uf
      If TempArray1(LoopCol, 1) = TempArray2(LoopCol2, 1) Then
         'do something
         ThisWorkbook.Worksheets(1).Range("A" & Uf1) = ThisWorkbook.Worksheets(2).Range("A" & Uf2)
      End If
    Next j 'j
Next i 'i

Next

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

Anexo archivo ejemplo.xlsm https://drive.google.com/file/d/1n9CLNEZ0uctRB1uGashDyso8patTrKC_/view?usp=sharing

2 respuestas 2

2

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:

  1. ¿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?

  2. Cuando ejecuto el proceso de la macro compartida, haciendo pruebas, cuando elimino una fila de datos de BD para hacer que la comparación sea sobre dos listas de diferente longitud los resultados cambian drásticamente, la macro busca palabras coincidentes específicas y no un conjunto de coincidencias contenida en la descripción. Por ejemplo:

introducir la descripción de la imagen aquí

introducir la descripción de la imagen aquí

  1. Es posible que cuando no hayan minimo 4 coincidencias de busqueda en las descripciones de cada cadena se devuelva como resultado "Crear nuevo código".

Agradezco su ayuda en el caso en estudio, Saludos

1

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

Tu Respuesta

By clicking “Publica tu respuesta”, you agree to our terms of service and acknowledge you have read our privacy policy.

¿No es la respuesta que buscas? Examina otras preguntas con la etiqueta o formula tu propia pregunta.