VBA

Question

背景：

作为我正在从事的项目的一部分，该项目涉及 fuzzy string matching, I have implemented the Levenshtein Distance algorithm in VBA to calculate the "similarity" between two strings (see 部分 code/more 对我的项目的洞察）。

因此，我在 Excel 中的 Sheet1 中创建了一个 table，行和列 headers 是字符串（位于单元格 A2:A2146 和 B1:TU1，分别），我正在将这些字符串与 LevenshteinDistance 函数进行比较。该函数用我称之为 matchScore 的内容填充 table（在我的例子中是 B2:TU2146）中的空单元格。思路是这样的：两个字符串越相似，它们的matchScore越低。因此，如果两个字符串完全匹配，我们将得到 matchScore = 0.

(1) 更具体地说，假设 S1（我的列 headers 之一）的值为 "recursion" 并且单元格 A532（其中之一我的行 headers) 是 "recursion"。执行我的 "similarity" 函数后，table 的单元格 S532 中返回的值是 0.

我想达到的效果：

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

数据table很大，我很难看到"good data"(matchScore <= 1)。 因此，我希望 Excel 在 table 中找到每个 <=1 的值，并将它们输出到 Sheet2 中与配对的字符串为 "good matches." 因此，Sheet2 中应该有三列数据。再次参考上面的示例 (1)，当我的代码完成运行时，我应该在单元格 A1 到 0、"recursion" 和 "recursion" 中看到 [= =32=]（假设这是我在 table 中找到的唯一 "good match"）。

我尝试实现的解决方案：

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 returns 是一个一维数组，而 .Value，当分配一个数组时，需要一个二维数组。所以我将作业分成了 3 行代码。

编辑令我惊讶的是，将一个从零开始的一维数组分配给单行范围的 .Value 属性效果很好，而我认为需要一个从零开始的二维数组。所以我上面的第一段是胡说八道，@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

在赋值语句和循环中限定工作表("sheet1")。将 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 - 从符合特定条件的 table 返回值并将它们输出到新的 sheet

VBA - Returning values from a table which fit a certain criteria and outputting them in a new sheet

string

excel

excel-2013