Question

背景

作为我正在处理的涉及fuzzy string matching的项目的一部分，我在VBA中实现了Levenshtein Distance算法来计算两个字符串之间的“相似性”（参见this question部分）代码/更深入了解我的项目。）

所以，我在Excel中的Sheet1创建了一个表，其中行和列标题是字符串（分别位于单元格A2:A2146和B1:TU1中），我正在比较这些字符串使用LevenshteinDistance功能。该函数使用我称之为B2:TU2146的表格填充表格中的空单元格（在我的例子中为matchScore）。这个想法是这样的：两个字符串越相似，它们matchScore就越低。因此，如果两个字符串完全匹配，我们将matchScore = 0。

（1）更具体地说，假设S1（我的一个列标题）的值是“递归”，并且单元格A532（我的一个行标题）的值是“递归” 。执行我的“相似性”功能后，表格的单元格S532中返回的值为0。

我想要实现的目标：

出于我的问题和启发式的目的，我已经定义了测量字符串相似性，我对matchScore <= 1为真的字符串对特别感兴趣（这包括上面的例子（1））。

数据表非常庞大，我很难看到“好数据”（matchScore <= 1）。 因此，我希望Excel能够找到表中的每个值＆lt; = 1并将其输出到 Sheet2 以及配对的字符串作为“匹配良好”。 “因此，Sheet2中应该有三列数据。要再次引用上面的示例（1），当我的代码完成运行时，我应该在单元格0到A1中看到C1，“递归”和“递归”（假设这是我在表中找到的唯一“好搭配”。）

我尝试将其作为解决方案实施：

Sub FindMatches()

Dim r As Long, c As Range
r = 1

For Each c In Range("B2:BY2146").Cells
    If c.Value <= 1 Then Sheets("Sheet2").Cells(r, 1).Resize(1, 3).Value = Array(c.Value, Cells(c.Row, 1), Cells(1, c.Column))
    r = r + 1
Next c

End Sub

实际上，这个子没有做任何事情。我试图实施解决方案的方式错在哪里，我该怎么做才能解决这个问题？

Answer 1

这是一个更新的子目录：

Sub FindMatches()
    On Error GoTo errHandler

    Dim r As Long, c As Range

    Application.ScreenUpdating = False

    With Sheets("Sheet2")
        r = 1
        For Each c In Range("B2:BY2146").Cells
            If c.Value <= 1 Then
                .Cells(r, 1).Resize(1, 3).Value = Array(c.Value, Cells(c.Row, 1).Value, Cells(1, c.Column).Value)
                r = r + 1
            End If                
        Next c
    End With

Recover:
    On Error Resume Next
    Application.ScreenUpdating = True
    Exit Sub

errHandler:
    MsgBox Err.Description, vbExclamation + vbOKOnly, "Error"
    Resume Recover
End Sub

请注意Array返回一维数组，而.Value在分配数组时需要2D数组。所以我将分配分为3行代码。

修改令我惊讶的是，为单行范围的.Value属性分配1D，从零开始的数组可以很好地工作，而我认为基于1的2D是必需的。所以我上面的第一段是胡扯，而@Profex确实找到了这个问题。

With块提供更多性能，Application.ScreenUpdating管理提供更多功能。如果出现错误，请务必将Application.ScreenUpdating重置为True。

请注意不合格的引用，即Range和Cells不在其父对象之前（例如... In Range("B2:BY2146").Cells和Cells(c.Row, 1);那些正在查看哪个工作表是活动的调用它们时。如果源值在Sheet1上，您可以使用例如... In Sheets("Sheet1").Range("B2:BY2146").Cells和Sheets("Sheet1").Cells(c.Row, 1)。

Answer 2

在作业声明中对资格表（＆＃34; sheet1＆＃34;）进行资格认证。环。将r = r + 1放在if语句中。

Sub FindMatches()

Dim r As Long, c As Range
r = 1

For Each c In Sheets("Sheet1").Range("B2:BY2146").Cells
If c.Value <= 1 Then
    Sheets("Sheet2").Range(Cells(r, 1), Cells(r, 3)).Value = Array(c.Value, Sheets("sheet1").Cells(c.Row, 1), Sheets("sheet1").Cells(1, c.Column).Value)
    r = r + 1
End If
Next c
End Sub

VBA - 从符合特定条件的表中返回值并将其输出到新工作表中

2 个答案: