Comparando seqüências de texto semelhantes no Excel

Atualmente, estou tentando reconciliar os campos "Nome" de duas fontes de dados separadas. Eu tenho vários nomes que não são exatamente iguais, mas estão próximos o suficiente para serem considerados correspondentes (exemplos abaixo). Você tem alguma idéia de como posso melhorar o número de correspondências automatizadas? Já estou eliminando as iniciais do meio dos critérios de correspondência.

Fórmula de correspondência atual:

=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")

Você pode considerar o uso do Microsoft Fuzzy Lookup Addin .

Do site da MS:

Visão geral

O Suplemento de Pesquisa Difusa para Excel foi desenvolvido pela Microsoft Research e executa a correspondência difusa de dados de texto no Microsoft Excel. Ele pode ser usado para identificar linhas duplicadas nebulosas em uma única tabela ou para juntar linhas semelhantes nebulosas entre duas tabelas diferentes. A correspondência é robusta a uma ampla variedade de erros, incluindo erros ortográficos, abreviações, sinônimos e dados adicionados / ausentes. Por exemplo, pode detectar que as linhas "Sr. Andrew Hill "," Hill, Andrew R. " e "Andy Hill" se referem à mesma entidade subjacente, retornando uma pontuação de similaridade a cada partida. Embora a configuração padrão funcione bem para uma ampla variedade de dados textuais, como nomes de produtos ou endereços de clientes, a correspondência também pode ser personalizada para domínios ou idiomas específicos.

Eu usaria esta lista (somente na seção em inglês) para ajudar a eliminar as diminuições comuns.

Além disso, você pode considerar o uso de uma função que informará, em termos exatos, quão "próximas" são duas cadeias. O código a seguir veio daqui e graças ao 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

O que isso fará é informar quantas inserções e exclusões devem ser feitas em uma string para chegar à outra. Eu tentaria manter esse número baixo (e os sobrenomes devem ser exatos).

Eu tenho uma fórmula (longa) que você pode usar. Não é tão aprimorado quanto os anteriores - e funciona apenas com sobrenome, e não com um nome completo -, mas você pode achar útil.

Então se você tem uma linha de cabeçalho e quiser comparar A2com B2, colocar isso em qualquer outra célula dessa linha (por exemplo, C2) e copiar até o fim.

= SE (A2 = B2, "EXATO", SE (SUBSTITUTO (A2, "-", "") = SUBSTITUTO (B2, "-", ""), "Hífen", SE (LEN (A2)> LEN ( B2), IF (LEN (A2)> LEN (SUBSTITUTE (A2, B2, "")), "String inteira", 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) + SE (MID (A2, LEN (A2), 1) = MID (B2, LEN (B2), 1), 1,0) + SE (MID (A2, LEN (A2) -1,1) = MID (B2, LEN (B2) -1,1), 1,0) + SE (MID (A2, LEN (A2) -2,1) = MID (B2, LEN (B2) -2,1), 1 , 0) & "°"), SE (LEN (B2)> LEN (SUBSTITUTE (B2, A2, "")), "String inteira", 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) + SE (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) + SE (MID (A2, LEN (A2) -2,1) = MID (B2, LEN (B2) - 2,1), 1,0) e "°")))))

Isso retornará:

• EXATO - se for uma correspondência exata
• Hífen - se for um par de nomes de barril duplo, mas tiver um hífen e o outro um espaço
• String inteira - se todo o sobrenome for parte do outro (por exemplo, se um Smith se tornar um Smith Francês)

Depois disso, você obterá um grau de 0 ° a 6 °, dependendo do número de pontos de comparação entre os dois. (ou seja, 6 ° compara melhor).

Como eu digo um pouco áspero e pronto, mas espero que você obtenha aproximadamente o parque de bola certo.

Estava procurando por algo semelhante. Encontrei o código abaixo. Espero que isso ajude o próximo usuário que vier a esta pergunta

Retorna 91% para Abracadabra / Abrakadabra, 75% para Hollywood Street / Hollyhood Str, 62% para Florença / França e 0 para Disneyland

Eu diria que é perto o suficiente do que você queria :)

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

Você pode usar a função de similaridade (pwrSIMILARITY) para comparar as seqüências de caracteres e obter uma porcentagem correspondente das duas. Você pode fazer distinção entre maiúsculas e minúsculas ou não. Você precisará decidir qual porcentagem de uma correspondência é "suficientemente próxima" para suas necessidades.

Há uma página de referência em http://officepowerups.com/help-support/excel-function-reference/excel-text-analyzer/pwrsimilarity/ .

Mas funciona muito bem para comparar o texto na coluna A com a coluna B.

Embora minha solução não permita identificar seqüências de caracteres muito diferentes, é útil para correspondência parcial (correspondência de substring), por exemplo, "this is a string" e "uma string" resultará em "matching":

basta adicionar "*" antes e depois da string para procurar na tabela.

Fórmula usual:

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

torna-se

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

"&" é a "versão curta" para concatenate ()

Essa coluna de verificação de código ae coluna b, se encontrar alguma similaridade nas duas colunas, será mostrada em amarelo. Você pode usar o filtro de cores para obter o valor final. Eu não adicionei essa parte no 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