Comparar coincidencias en 2 Matrices (Arrays) VBA

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

Respuesta
4

Voy a tratar de explicar lo que necesitas con una 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"

----

Prueba la siguiente macro, realiza todos los cálculos y comparaciones en memoria; y solamente hasta el final, despliega el resultado en la hoja "Lista", lo que la hace muy rápida.

Option Explicit
Sub CompararCoincidencias()
'Por Dante Amor
  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

Te anexo mi archivo de pruebas.

https://drive.google.com/file/d/1EvFv9H5XoXbijtzCFhQyT_P2wdOqWy07/view?usp=sharing 


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"

¡Mil Gracias! Sos un crack! Un trabajo impecable, me ha servido mucho, de esta forma reduciré de forma muy significativa mi "trabajo manual"; viéndolo desde este enfoque que me brindas es muy entendible, pero me queda una sola inquietud, y es que si es posible que cuando la macro no encuentre coincidencias "imprescindibles" o "claves" donde estans incluyan el tipo de accesorio (Tee, buje, Válvula, etc) y/o dimensiones (4"-3/4"-1/2") el valor que se devuelve como resultado no sea un código con una descripción de un grado coincidente mayor si no más bien el valor "Crear Nuevo Código", es una inquietud solo de pensar si es posible ya que tu macro es lo que necesitaba y es muy entendible, con vos se aprende mucho. Nuevamente muchas gracias y saludos.

"Si es posible que cuando la macro no encuentre coincidencias "imprescindibles" ... tipo de accesorio (Tee, buje, Válvula, etc) y/o dimensiones (4"-3/4"-1/2") el valor que se devuelve ... "Crear Nuevo Código""

Agrega estas líneas:

    Else
      'si no encuentra el tema
      codigo = "Crear Nuevo Código"

En esta parte:

        Next palabra
        If n > nmax Then
          nmax = n
          codigo = Split(c(fil, x), "|")(0)
        End If
      Next x
    Else
      'si no encuentra el tema
      codigo = "Crear Nuevo Código"
    End If
    If codigo <> "" Then b(i, 1) = codigo
  Next i
Respuesta
3

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:

1. ¿Es posible que haya una la coincidencia clave como lo son las dimensiones? Por ejemplo: Dimensiones: Ø4"-Ø4"-Ø4". para así obtener un mayor grado de similitud o coincidencias.

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:

https://foro.todoexcel.com/attachments/1657384227037-png.87691/

https://foro.todoexcel.com/attachments/1657384246289-png.87692/

3. 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".

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas