3

我开发了以下代码来比较 A 和 D 列中的两个单元格（字符串），如果找到部分匹配，则在相应的 B 单元格中写下 D 单元格值。

Sub CompareAndGuess()
Dim strLen, aux As Integer
Dim max1, max2 As Long
Dim str As String

Range("A1").Select
Selection.End(xlDown).Select
max1 = ActiveCell.Row
Range("D1").Select
Selection.End(xlDown).Select
max2 = ActiveCell.Row

For a = 2 To max1
    str = Cells(a, 1)
    str = StrConv(str, vbUpperCase)
    strLen = Len(str)
    aux = strLen

    For l = 3 To strLen
         For d = 2 To max2
             If Cells(d, 4) = Left(str, aux) Then
                Cells(a, 2) = Cells(d, 4)
                Exit For
            ElseIf Cells(d, 4) = Right(str, aux) Then
                Cells(a, 2) = Cells(d, 4)
                Exit For
            End If
        Next d

        aux = aux - 1
        If Cells(a, 2) <> "" Then
            Exit For
        End If
    Next l
     Cells(a, 2).Select
Next a
End Sub

谁能帮我找出问题出在哪里，因为当我运行它时，代码只能猜对 50 行中的一行，而它应该至少匹配 40 左右。

拜托，我真的找不到那里的错误。如果您愿意，请随时为我的问题提出另一种解决方案。

我正在分析的数据样本是： 有错别字的名称：-

Jatiuca
Pajuara
Poco
Santa Luzia
Pajucara
Domingos Acacio
Jaragua
Stella Maris
P Verde
Tabuleiro dos Martin
Gruta Lourdes
Brasilia
Centro Historico
Monumento
Tabuleiro dos Martins

要在此列表中搜索的带有拼写错误的名称：- 

JARAGUÁ
TABULEIRO DO MARTINS
CENTRO
BRASÍLIA
CACIMBAS
JATIÚCA
CAITITUS
PAJUÇARA
CANAÃ
PONTA VERDE
CANAFÍSTULA
POÇO
CAPIATÃ
CAVACO
SANTA LÚCIA
4

3 回答 3

3

I've found the right way to do it with everyone's help. Here it is:

        If InStr(1, Cells(d, 4), Left(str, aux)) = 1 Then
            Cells(a, 2) = Cells(d, 4)
            Exit For
        ElseIf InStr(Cells(d, 4), Right(str, aux)) + strLen - aux = strLen Then
            Cells(a, 2) = Cells(d, 4)
            Exit For
        End If
于 2013-09-26T23:44:52.540 回答
0

这绝对是未经测试的

我明天会重写并清理它，但这是真正知道你匹配正确单词的基本方法。这可能需要更长的时间，我明天会加快速度，但现在这是测试单词有效性的壁橱方法

'Go through all possibly typod words
For each rngTestCell in Range("yourlist")

   'For each possibly typod word test if against every correct value
    For each rngCorrectedValue in Range("ListOfCorrectValues")

        'start by testing length to weed out most values quick
        'Test any words that are within 3 letters of each other, can be less
        'could add a tet for first and last letters match also before starting 
        'to match every letter also, just a top level weeding of words
        If (Len(rngTestCell) - Len(rngCorrectedValue)) < 3 Then

           'loop each letter in the words for match keep a record of how many are matched
           for i = 1 to Len(rngTestCell)

                If rngTestCell.Character(i,1) = rngCorrectedValue.Characters(i,1) Then
                     NumberOfMatches = NumberOfMatches + 1
                End If

            next i

            'if enough of the letters match replace the word, this will need updating because
            'i feel using a ratio of more then 10% of the words match then replace
            'but for now if more then 2 letters don't match then it isn't a match
            If (Len(rngTestCell) - NumberOfMatches) > 2 Then 'Less then 2 letters are different
                rngTestCell.Offset(,1).Value = rngCorrectedValue.Value
                Exit Loop
            End If

        End If

    Next rngCorrectedValues

Next rngTestCell
于 2013-09-27T00:54:21.683 回答
0

很高兴您使用 InStr 函数自己解决了问题。您的代码运行不佳的原因是您将名称的缩短版本与完整版本进行比较。使用以下内容修改您之前的代码会发现更多匹配项。

            If Left(Cells(d, 4), aux) = Left(str, aux) Then
                Cells(a, 2) = Cells(d, 4)
                Exit For
            ElseIf Right(Cells(d, 4), aux) = Right(str, aux) Then
                Cells(a, 2) = Cells(d, 4)
                Exit For
            End If
于 2013-09-26T23:59:05.580 回答