Comparación de cadenas de texto similares en Excel

Actualmente estoy tratando de conciliar los campos "Nombre" de dos fuentes de datos separadas. Tengo varios nombres que no coinciden exactamente pero que son lo suficientemente cercanos como para ser considerados coincidentes (ejemplos a continuación). ¿Tienes alguna idea de cómo puedo mejorar la cantidad de coincidencias automáticas? Ya estoy eliminando las iniciales del segundo nombre de los criterios de coincidencia.

Fórmula actual del partido:

=IFERROR(IF(LEFT(SYSTEM A,IF(ISERROR(SEARCH(" ",SYSTEM A)),LEN(SYSTEM A),SEARCH(" ",SYSTEM A)-1))=LEFT(SYSTEM B,IF(ISERROR(SEARCH(" ",SYSTEM B)),LEN(SYSTEM B),SEARCH(" ",SYSTEM B)-1)),"",IF(LEFT(SYSTEM A,FIND(",",SYSTEM A))=LEFT(SYSTEM B,FIND(",",SYSTEM B)),"Last Name Match","RESEARCH")),"RESEARCH")

Puede considerar usar el complemento de búsqueda difusa de Microsoft .

Desde el sitio de MS:

Visión general

El complemento Fuzzy Lookup para Excel fue desarrollado por Microsoft Research y realiza una coincidencia difusa de datos textuales en Microsoft Excel. Se puede usar para identificar filas duplicadas difusas dentro de una sola tabla o para unir difusamente filas similares entre dos tablas diferentes. La coincidencia es robusta para una amplia variedad de errores, incluidos errores ortográficos, abreviaturas, sinónimos y datos agregados / faltantes. Por ejemplo, podría detectar que las filas "Sr. Andrew Hill "," Hill, Andrew R. " y "Andy Hill" se refieren a la misma entidad subyacente, devolviendo un puntaje de similitud junto con cada coincidencia. Si bien la configuración predeterminada funciona bien para una amplia variedad de datos textuales, como nombres de productos o direcciones de clientes, la coincidencia también se puede personalizar para dominios o idiomas específicos.

Me gustaría usar esta lista (solo en la sección en inglés) para ayudar a eliminar las abreviaturas comunes.

Además, es posible que desee considerar el uso de una función que le dirá, en términos exactos, qué tan "cerradas" están las dos cadenas. El siguiente código vino de aquí y gracias a smirkingman .

Option Explicit
Public Function Levenshtein(s1 As String, s2 As String)

Dim i As Integer
Dim j As Integer
Dim l1 As Integer
Dim l2 As Integer
Dim d() As Integer
Dim min1 As Integer
Dim min2 As Integer

l1 = Len(s1)
l2 = Len(s2)
ReDim d(l1, l2)
For i = 0 To l1
    d(i, 0) = i
Next
For j = 0 To l2
    d(0, j) = j
Next
For i = 1 To l1
    For j = 1 To l2
        If Mid(s1, i, 1) = Mid(s2, j, 1) Then
            d(i, j) = d(i - 1, j - 1)
        Else
            min1 = d(i - 1, j) + 1
            min2 = d(i, j - 1) + 1
            If min2 < min1 Then
                min1 = min2
            End If
            min2 = d(i - 1, j - 1) + 1
            If min2 < min1 Then
                min1 = min2
            End If
            d(i, j) = min1
        End If
    Next
Next
Levenshtein = d(l1, l2)
End Function

Lo que esto hará es decirle cuántas inserciones y eliminaciones debe hacer una a una cadena para llegar a la otra. Intentaría mantener este número bajo (y los apellidos deberían ser exactos).

Tengo una fórmula (larga) que puedes usar. No está tan bien pulido como los anteriores, y solo funciona para el apellido, en lugar de un nombre completo, pero puede resultarle útil.

Así que si usted tiene una fila de encabezado y quiere comparar A2con B2, colocar esto en cualquier otra celda de esa fila (por ejemplo, C2) y copiar hasta el final.

= SI (A2 = B2, "EXACTO", SI (SUSTITUTO (A2, "-", "") = SUBSTITUTO (B2, "-", ""), "Guión", SI (LEN (A2)> LEN ( B2), IF (LEN (A2)> LEN (SUSTITUTO (A2, B2, "")), "Cadena entera", IF (MID (A2,1,1) = MID (B2,1,1), 1, 0) + IF (MID (A2,2,1) = MID (B2,2,1), 1,0) + IF (MID (A2,3,1) = MID (B2,3,1), 1, 0) + IF (MID (A2, LEN (A2), 1) = MID (B2, LEN (B2), 1), 1,0) + IF (MID (A2, LEN (A2) -1,1) = MID (B2, LEN (B2) -1,1), 1,0) + IF (MID (A2, LEN (A2) -2,1) = MID (B2, LEN (B2) -2,1), 1 , 0) & "°"), IF (LEN (B2)> LEN (SUBSTITUTE (B2, A2, "")), "Whole String", IF (MID (A2,1,1) = MID (B2,1 , 1), 1,0) + IF (MID (A2,2,1) = MID (B2,2,1), 1,0) + IF (MID (A2,3,1) = MID (B2,3 , 1), 1,0) + IF (MID (A2, LEN (A2), 1) = MID (B2, LEN (B2), 1), 1,0) + IF (MID (A2, LEN (A2) -1,1) = MID (B2, LEN (B2) -1,1), 1,0) + IF (MID (A2, LEN (A2) -2,1) = MID (B2, LEN (B2) - 2,1), 1,0) y "°"))))

Esto devolverá:

• EXACTO - si es una coincidencia exacta
• Guión : si se trata de un par de nombres de doble cañón, pero en tiene un guión y el otro un espacio
• Cadena completa : si todos los apellidos son parte del otro (por ejemplo, si un Smith se ha convertido en un French-Smith)

Después de eso, le dará un grado de 0 ° a 6 ° dependiendo del número de puntos de comparación entre los dos. (es decir, 6 ° se compara mejor).

Como digo un poco áspero y listo, pero espero que te lleve aproximadamente al estadio correcto.

Estaba buscando algo similar. Encontré el código a continuación. Espero que esto ayude al próximo usuario que viene a esta pregunta

Devuelve 91% para Abracadabra / Abrakadabra, 75% para Hollywood Street / Hollyhood Str, 62% para Florencia / Francia y 0 para Disneyland

Yo diría que está lo suficientemente cerca de lo que querías :)

Public Function Similarity(ByVal String1 As String, _
    ByVal String2 As String, _
    Optional ByRef RetMatch As String, _
    Optional min_match = 1) As Single
Dim b1() As Byte, b2() As Byte
Dim lngLen1 As Long, lngLen2 As Long
Dim lngResult As Long

If UCase(String1) = UCase(String2) Then
    Similarity = 1
Else:
    lngLen1 = Len(String1)
    lngLen2 = Len(String2)
    If (lngLen1 = 0) Or (lngLen2 = 0) Then
        Similarity = 0
    Else:
        b1() = StrConv(UCase(String1), vbFromUnicode)
        b2() = StrConv(UCase(String2), vbFromUnicode)
        lngResult = Similarity_sub(0, lngLen1 - 1, _
        0, lngLen2 - 1, _
        b1, b2, _
        String1, _
        RetMatch, _
        min_match)
        Erase b1
        Erase b2
        If lngLen1 >= lngLen2 Then
            Similarity = lngResult / lngLen1
        Else
            Similarity = lngResult / lngLen2
        End If
    End If
End If

End Function

Private Function Similarity_sub(ByVal start1 As Long, ByVal end1 As Long, _
                                ByVal start2 As Long, ByVal end2 As Long, _
                                ByRef b1() As Byte, ByRef b2() As Byte, _
                                ByVal FirstString As String, _
                                ByRef RetMatch As String, _
                                ByVal min_match As Long, _
                                Optional recur_level As Integer = 0) As Long
'* CALLED BY: Similarity *(RECURSIVE)

Dim lngCurr1 As Long, lngCurr2 As Long
Dim lngMatchAt1 As Long, lngMatchAt2 As Long
Dim I As Long
Dim lngLongestMatch As Long, lngLocalLongestMatch As Long
Dim strRetMatch1 As String, strRetMatch2 As String

If (start1 > end1) Or (start1 < 0) Or (end1 - start1 + 1 < min_match) _
Or (start2 > end2) Or (start2 < 0) Or (end2 - start2 + 1 < min_match) Then
    Exit Function '(exit if start/end is out of string, or length is too short)
End If

For lngCurr1 = start1 To end1
    For lngCurr2 = start2 To end2
        I = 0
        Do Until b1(lngCurr1 + I) <> b2(lngCurr2 + I)
            I = I + 1
            If I > lngLongestMatch Then
                lngMatchAt1 = lngCurr1
                lngMatchAt2 = lngCurr2
                lngLongestMatch = I
            End If
            If (lngCurr1 + I) > end1 Or (lngCurr2 + I) > end2 Then Exit Do
        Loop
    Next lngCurr2
Next lngCurr1

If lngLongestMatch < min_match Then Exit Function

lngLocalLongestMatch = lngLongestMatch
RetMatch = ""

lngLongestMatch = lngLongestMatch _
+ Similarity_sub(start1, lngMatchAt1 - 1, _
start2, lngMatchAt2 - 1, _
b1, b2, _
FirstString, _
strRetMatch1, _
min_match, _
recur_level + 1)
If strRetMatch1 <> "" Then
    RetMatch = RetMatch & strRetMatch1 & "*"
Else
    RetMatch = RetMatch & IIf(recur_level = 0 _
    And lngLocalLongestMatch > 0 _
    And (lngMatchAt1 > 1 Or lngMatchAt2 > 1) _
    , "*", "")
End If


RetMatch = RetMatch & Mid$(FirstString, lngMatchAt1 + 1, lngLocalLongestMatch)


lngLongestMatch = lngLongestMatch _
+ Similarity_sub(lngMatchAt1 + lngLocalLongestMatch, end1, _
lngMatchAt2 + lngLocalLongestMatch, end2, _
b1, b2, _
FirstString, _
strRetMatch2, _
min_match, _
recur_level + 1)

If strRetMatch2 <> "" Then
    RetMatch = RetMatch & "*" & strRetMatch2
Else
    RetMatch = RetMatch & IIf(recur_level = 0 _
    And lngLocalLongestMatch > 0 _
    And ((lngMatchAt1 + lngLocalLongestMatch < end1) _
    Or (lngMatchAt2 + lngLocalLongestMatch < end2)) _
    , "*", "")
End If

Similarity_sub = lngLongestMatch

End Function

Puede usar la función de similitud (pwrSIMILARITY) para comparar las cadenas y obtener un porcentaje de coincidencia de las dos. Puedes hacerlo sensible a mayúsculas o no. Tendrá que decidir qué porcentaje de una coincidencia es "lo suficientemente cerca" para sus necesidades.

Hay una página de referencia en http://officepowerups.com/help-support/excel-function-reference/excel-text-analyzer/pwrsimilarity/ .

Pero funciona bastante bien para comparar texto en la columna A con la columna B.

Aunque mi solución no permite identificar cadenas muy diferentes, es útil para la coincidencia parcial (coincidencia de subcadena), por ejemplo, "esto es una cadena" y "una cadena" resultará como "coincidencia":

simplemente agregue "*" antes y después de la cadena para buscar en la tabla.

Fórmula habitual:

• vlookup (A1, B1: B10,1,0)
• cerca.vert (A1; B1: B10; 1; 0)

se convierte

• vlookup ("*" y A1 y "*", B1: B10; 1,0)
• cerca.vert ("*" & A1 & "*"; B1: B10; 1; 0)

"&" es la "versión corta" para concatenate ()

Este código escanea la columna a y la columna b, si encuentra alguna similitud en ambas columnas, se muestra en amarillo. Puede usar el filtro de color para obtener el valor final. No he agregado esa parte al código.

Sub item_difference()

Range("A1").Select

last_row_all = Range("A65536").End(xlUp).Row
last_row_new = Range("B65536").End(xlUp).Row

Range("A1:B" & last_row_new).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 65535
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With

For i = 1 To last_row_new
For j = 1 To last_row_all

If Range("A" & i).Value = Range("A" & j).Value Then

Range("A" & i & ":B" & i).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorDark1
    .TintAndShade = 0
  .PatternTintAndShade = 0
End With

End If
Next j
Next i
End Sub