2

Tengo una macro que resalta el texto de dos listas según similitudes y diferencias, a continuación la comparto:

Sub highlight()
    Dim xRg1 As Range
    Dim xRg2 As Range
    Dim xTxt As String
    Dim xCell1 As Range
    Dim xCell2 As Range
    Dim I As Long
    Dim J As Integer
    Dim xLen As Integer
    Dim xDiffs As Boolean
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
      xTxt = ActiveSheet.UsedRange.AddressLocal
    End If
lOne:
    Set xRg1 = Application.InputBox("Range A:", "ML1", xTxt, , , , , 8)
    If xRg1 Is Nothing Then Exit Sub
    If xRg1.Columns.Count > 1 Or xRg1.Areas.Count > 1 Then
        MsgBox "Multiple ranges or columns have been selected ", vbInformation, "ML1"
        GoTo lOne
    End If
lTwo:
    Set xRg2 = Application.InputBox("Range B:", "ML1", "", , , , , 8)
    If xRg2 Is Nothing Then Exit Sub
    If xRg2.Columns.Count > 1 Or xRg2.Areas.Count > 1 Then
        MsgBox "Multiple ranges or columns have been selected ", vbInformation, "ML1"
        GoTo lTwo
    End If
    If xRg1.CountLarge <> xRg2.CountLarge Then
       MsgBox "Two selected ranges must have the same numbers of cells ", vbInformation, "ML1"
       GoTo lTwo
    End If
    xDiffs = (MsgBox("Click Yes to highlight similarities, click No to highlight differences ", vbYesNo + vbQuestion, "ML1") = vbNo)
    Application.ScreenUpdating = False
    xRg2.Font.ColorIndex = xlAutomatic
    For I = 1 To xRg1.Count
        Set xCell1 = xRg1.Cells(I)
        Set xCell2 = xRg2.Cells(I)
        If xCell1.Value2 = xCell2.Value2 Then
            If Not xDiffs Then xCell2.Font.Color = vbRed
        Else
            xLen = Len(xCell1.Value2)
            For J = 1 To xLen
                If Not xCell1.Characters(J, 1).Text = xCell2.Characters(J, 1).Text Then Exit For
            Next J
            If Not xDiffs Then
                If J <= Len(xCell2.Value2) And J > 1 Then
                    xCell2.Characters(1, J - 1).Font.Color = vbRed
                End If
            Else
                If J <= Len(xCell2.Value2) Then
                    xCell2.Characters(J, Len(xCell2.Value2) - J + 1).Font.Color = vbRed
                End If
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Estoy pidiendo su ayuda para que en la comparación no tenga en cuenta tildes, mayúsculas o minúsculas; esta macro compara dos listas (Lista - BD) según la celda correspondiente pero lo que quiero es que compare el primer valor de la hoja Lista con todos los valores de la hoja BD y así sucesivamente buscando similitudes y según esto devuelva el valor Código en la hoja Lista en el rango correspondiente A2:A.

Ejemplo,

Este valor dispuesto en la hoja Lista en la celda B2 introducir la descripción de la imagen aquí lo debe comparar con todo el rango B2:B de la hoja BD introducir la descripción de la imagen aquí y así sucesivamente con todos los valores de la columna Descripción dispuestos en la hoja Lista.

En el caso de que encuentre similitudes concretas en el valor comparado del rango dispuesto en la hoja Lista tales como:

Lista introducir la descripción de la imagen aquí BD introducir la descripción de la imagen aquí devolver el valor del Código de la hoja BD a la hoja Lista.

Les dejo el archivo ejemplo.xlsx agradeciendo enormemente la ayuda que me puedan brindar en este caso.

https://drive.google.com/file/d/1YQqFLDT9aes4Avze-nzASlPZjeMOnkbb/view?usp=sharing

Nota: Vale aclarar que el texto de la lista de la hoja BD usualmente esta formulado.

**Actualización: Lista introducir la descripción de la imagen aquí

Saludos.

12
  • 2
    Buen día, en cuanto a encontrar las similitudes, ¿La idea es que la letra coincida en ambos string en la misma posición? o ¿Buscar dentro de todas las palabras de los strings y marcar las palabras que son iguales sin importar la posición? Commented el 4 jul. 2022 a las 6:23
  • 2
    Pero entonces la idea de lo que quieres lograr no se refleja en lo que has hecho hasta ahora ya que estás comparando letra por letra y marcando las que coinciden en la misma posición. Yo creo que lo mejor sería convertir cada celda en un arreglo de palabras y al iterar entonces tendría que recorrer el rango y luego los arreglos de palabras. Commented el 4 jul. 2022 a las 14:48
  • 2
    Aparte del diámetro, ¿Hay alguna otra “equivalencia” que considerar? Commented el 4 jul. 2022 a las 23:00
  • 2
    No hay de que, lo que se me ocurre para las equivalencias sería crear una tercera pestaña y ahí declarar las equivalencias, de esa forma sería posible editar, agregar o eliminar equivalencias y el código sería escalable. ¿Habría algún inconveniente con agregar una tercera pestaña? Commented el 5 jul. 2022 a las 1:50
  • 2
    El mayor problema que yo veo es que a final de cuentas ambos textos son escritos por humanos que podrían escribir bien o mal (Con faltas ortográficas) una o varias palabras, por lo que el código tendría que irse adaptando cada vez que se agreguen elementos a menos que se pongan normas al agregar nuevos datos (Por ejemplo, si se utiliza el sistema métrico o imperial, abreviaciones o palabras completas, etc...) Estoy empezando a pensar que lo más conveniente sería utilizar una IA que "aprenda" de lo que ya está escrito y se adapte a lo que vaya a agregarse en el futuro. Commented el 5 jul. 2022 a las 2:12

2 respuestas 2

5
+50

Buen día,

Como lo platicamos en los comentarios y en el chat, hay una gran diferencia entre la pregunta y el objetivo que se desea lograr, para poder hacer una comparación real de similitudes habrá que obtener el contexto de una frase y analizar su interpretación para que se valide y devuelva resultados correctos, por lo tanto yo te recomendaría utiliza una IA y tal vez otro lenguaje de programación

Pero enfocándonos únicamente en los dos puntos de la pregunta que son:

  1. Posibilidad de comparar mayúsculas con minúsculas.
  2. Posibilidad de comparar letras con acentos y sin acentos (Es decir á y a deben interpretarse como iguales).

Comparar mayúsculas con minúsculas

Lo más fácil es obtener el texto de las celdas y convertir todo a minúsculas en un string temporal, para eso se puede utilizar la función LCase()

'Convertimos la cadena a minúsculas
tempCell1 = LCase(xCell1.Value2)
tempCell2 = LCase(xCell2.Value2)

Y utilizamos esos string temporales para la comparación utilizando la función Mid() para obtener los caracteres del string

For J = 1 To xLen
    If Not Mid(tempCell1, J, 1) = Mid(tempCell2, J, 1) Then Exit For
Next J

Comparar letras acentuadas con su equivalente no acentuado

Lo más fácil es crear una función que elimine los acentos y convierta las letras acentuadas a su equivalente no acentuado

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

Y utilizarlo de la siguiente forma:

'Strip accents
tempCell1 = stripAccent((tempCell1))
tempCell2 = stripAccent((tempCell2))

Ejemplo completo

Sub highlight()
    Dim xRg1 As Range
    Dim xRg2 As Range
    Dim xTxt As String
    Dim xCell1 As Range
    Dim xCell2 As Range
    Dim i As Long
    Dim J As Integer
    Dim xLen As Integer
    Dim xDiffs As Boolean
    Dim tempCell1, tempCell2 As String
    
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
      xTxt = ActiveSheet.UsedRange.AddressLocal
    End If
lOne:
    Set xRg1 = Application.InputBox("Range A:", "ML1", xTxt, , , , , 8)
    If xRg1 Is Nothing Then Exit Sub
    If xRg1.Columns.Count > 1 Or xRg1.Areas.Count > 1 Then
        MsgBox "Multiple ranges or columns have been selected ", vbInformation, "ML1"
        GoTo lOne
    End If
lTwo:
    Set xRg2 = Application.InputBox("Range B:", "ML1", "", , , , , 8)
    If xRg2 Is Nothing Then Exit Sub
    If xRg2.Columns.Count > 1 Or xRg2.Areas.Count > 1 Then
        MsgBox "Multiple ranges or columns have been selected ", vbInformation, "ML1"
        GoTo lTwo
    End If
    If xRg1.CountLarge <> xRg2.CountLarge Then
       MsgBox "Two selected ranges must have the same numbers of cells ", vbInformation, "ML1"
       GoTo lTwo
    End If
    xDiffs = (MsgBox("Click Yes to highlight similarities, click No to highlight differences ", vbYesNo + vbQuestion, "ML1") = vbNo)
    Application.ScreenUpdating = False
    xRg2.Font.ColorIndex = xlAutomatic
    For i = 1 To xRg1.Count
        Set xCell1 = xRg1.Cells(i)
        Set xCell2 = xRg2.Cells(i)
        
        'Convertimos la cadena a minúsculas
        tempCell1 = LCase(xCell1.Value2)
        tempCell2 = LCase(xCell2.Value2)
        
        'Strip accents
        tempCell1 = stripAccent((tempCell1))
        tempCell2 = stripAccent((tempCell2))
        
        If tempCell1 = tempCell2 Then
            If Not xDiffs Then xCell2.Font.Color = vbRed
        Else
            xLen = Len(xCell1.Value2)
            For J = 1 To xLen
                If Not Mid(tempCell1, J, 1) = Mid(tempCell2, J, 1) Then Exit For
                'If Not LCase(xCell1.Characters(J, 1).Text) = LCase(xCell2.Characters(J, 1).Text) Then Exit For
            Next J
            If Not xDiffs Then
                If J <= Len(xCell2.Value2) And J > 1 Then
                    xCell2.Characters(1, J - 1).Font.Color = vbRed
                End If
            Else
                If J <= Len(xCell2.Value2) Then
                    xCell2.Characters(J, Len(xCell2.Value2) - J + 1).Font.Color = vbRed
                End If
            End If
        End If
    Next
    Application.ScreenUpdating = True
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

Edición: Agrego imagen con el resultado, como se puede ver las mayúsculas y letras acentuadas son marcadas correctamente

Imagen

Nota: Recuerda que en Stack Overflow trabajamos con problemas puntuales, por lo que hacer todo el proyecto de comparar las frases enteras e interpretarlas, tal vez utilizar una IA, etc... está fuera de los lineamientos del sitio. Tal como lo platicamos en el chat, yo creo que una buena estrategia sería convertir el contenido de las celdas en un arreglo y contar el número de palabras iguales, tal vez eso te ayude a avanzar y saber qué filas son más "similares" entre las dos tablas

5
  • 1
    Un gran aporte, agradezco mucho tu ayuda con el post, saludos Commented el 6 jul. 2022 a las 1:33
  • 1
    Solo me faltaria comparar toda la frase Descripción, especialmente con un diferenciador de similitudes contenido en el equivalente de dimensiones que en este caso sería la columna Size, el ejemplo que me propones funciona bien, solo faltaria que devolviera el valor del Código de la BD a la hoja Lista según la similitud encontrada. Nuevamente gracias por este aporte, que servirá como un punto de partida muy avanzado. Commented el 6 jul. 2022 a las 2:34
  • 2
    Te recomendaría utilizar un contador de similitudes entre las filas de ambas tablas y utilizar la fila con el número mayor. Luego puedes utilizar la función VLOOKUP o XLOOKUP (O su equivalente en Excel en español, el mío está en inglés) para obtener el valor del código, el copiar el valor de la fila con coincidencias es fácil utilizando alguna de esas funciones Commented el 6 jul. 2022 a las 2:39
  • Voy a intentar con usando la función StrComp para comparar dos cadenas de texto, lo de VLOOKUP o XLOOKUP no me queda claro. Lo intentare y si lo logro lo compartire. Commented el 6 jul. 2022 a las 2:47
  • 1
    StrComp no va a funcionar del todo porque los string son diferentes, por eso en los comentarios anteriores y el chat te recomendé utilizar array y comparar los elementos. Información de VLOOKUP y XLOOKUP. Estas funciones se utilizan para buscar celdas en la misma fila de un valor determinado, por ejemplo buscas X descripción y obtienes el valor del código de la misma fila de la descripción que buscaste. Commented el 6 jul. 2022 a las 2:56
2

Buen día estimada.

Lo que tengo para que te solucione el tema de acentos mayúsculas y en mi caso caracteres especiales, para que compare netamente el texto utilizo una columna auxiliar con esta funcion: =+MAYUSC(SUSTITUIR(SUSTITUIR(SUSTITUIR(SUSTITUIR( SUSTITUIR( SUSTITUIR( SUSTITUIR( SUSTITUIR( SUSTITUIR( SUSTITUIR( SUSTITUIR( SUSTITUIR( SUSTITUIR(A2; "á"; "a"); "é"; "e"); "í"; "i"); "ó"; "o"); "ú"; "u"); "Á"; "A"); "É"; "E"); "Í"; "I"); "Ó"; "O"); "Ú"; "U");" ";"");",";"");".";"")) Y tu le cambias el A2 por tu celda que necesitas o borras si es que quieres que se mantengan los espacios o caracteres de puntuación que en mi caso no los quería.

Luego para el problema de buscar caracteres similares coincido que deberías tener otras columnas donde diga diámetro y una columna para cada variable, eso como concejo que quieres actualizar tu BD alguna vez a algo más entendible, pero se muy bien que esto es muy tedioso y a veces necesitamos una solución rápida o que nos funcione por el momento, yo lo que hacia es crearme un excel auxiliar o en la misma hoja un "BUSCADOR" que es lo que entiendo quieres hacer y creo que va por ese lado.

BUSCADOR AUXILIAR

O también puedes convertir tus BD en tablas, bueno la idea es que en la imagen busque por las letras en la columna descripción sin importar el orden en el que esta. con esto me filtra los caracteres (tiene algunas limitaciones claro, pero me parece una solución rápida y efectiva).

FILTRADO

Como podrás ver no distingue de mayúscula o minúscula así que no necesitas la columna auxiliar inicial.

Para replicar tienes que insertar un cuadro de texto para leer por ese los caracteres que vas ingresando, y el codigo es el siguiente en mi ejemplo.

Private Sub TextBox1_Change()

Dim Criterio As String

'Para que no salga la pantalla de parpadeo al inicio
Application.ScreenUpdating = False


If Hoja1.TextBox1.Value <> "" Then

    Criterio = "*" & Hoja1.TextBox1.Value & "*"
    
    Range("A10").CurrentRegion.AutoFilter Field:=2, Criteria1:=Criterio
        
    Else
    
    Criterio = ""

    Range("A10").CurrentRegion.AutoFilter
    
    End If
            

End Sub

1
  • 1
    agradezco enormemente tu ayuda, voy a intentarlo de esa forma. Commented el 5 jul. 2022 a las 23:07

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.