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 FunctionAnexo archivo ejemplo.xlsm https://drive.google.com/file/d/1n9CLNEZ0uctRB1uGashDyso8patTrKC_/view?usp=sharing
2 Respuestas
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 SubProceso 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:
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".
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 FunctionTe 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