Question

我有一个宏在两张纸上循环，比较每个单元格中的单词。代码工作正常，但有没有办法提高效率或速度？我手动使用for循环来比较字符串数组，因为我没有找到任何VBA函数来执行此操作。我确实关闭了ScreenUpdating，这似乎有点帮助。

For i = 2 To maxMn 'loop 1
    Sheets("Sh1").Select
    Cells(i, 2).Select
    mnStr = Cells(i, 2).Value
    mnArr = Split(mnStr, " ")

    x = 2
    For x = 2 To maxNm 'loop 2
        numTotal = 0
        numMatches = 0
        Sheets("Sh2").Select
        Cells(x, 6).Select
        nameStr = Cells(x, 6).Value
        nameArr = Split(nameStr, " ")
        For Each mn In mnArr 'loop 3
            For Each nam In nameArr 'loop 4
                Application.StatusBar = "(#" & i & " Sh1) (#" & x & " Sh2): Comparing " & mn & " to " & nam
                If LCase(nam) = LCase(mn) Then
                    'MsgBox "Yes, '" & nam & "' equal to " & mn
                    numMatches = numMatches + 1
                Else
                    'MsgBox "No, '" & nam & "' does not equal " & mn
                End If
            Next nam '4: For Each nam In nameArr
            numTotal = numTotal + 1
        Next mn '3: For Each mn In mnArr
        If numTotal > 2 And numTotal > 0 And numMatches >= numTotal / 2 Then
            LogMsg = "(#" & i & " Sh1) (#" & x & " Sh2): |" & mnStr & "| - |" & nameStr & "| = " & numMatches & "/" & numTotal & " matches."
            Print #FileNum, LogMsg
            'MsgBox numMatches & " matches out of " & numTotal & " total."
        End If
    Next x '2: For x = 2 To maxNm
Next i '1: For i = 2 To maxMn

Answer 1

提高效率的第一条规则是不要选择或激活任何东西。对于分别为300行和200行的数据集，您的代码需要13.5分钟。只需删除选择

    For i = 2 To maxMn 'loop 1
        'Sheets("Sh1").Select
        'Cells(i, 2).Select
        mnStr = Sheets("Sh1").Cells(i, 2).Value
        mnArr = Split(mnStr, " ")

        x = 2
        For x = 2 To maxNm 'loop 2
            numTotal = 0
            numMatches = 0
            'Sheets("Sh2").Select
            'Cells(x, 6).Select
            nameStr = Sheets("Sh2").Cells(x, 6).Value

将时间缩短为154秒。屏幕重绘是单个最大的时间下沉。以下代码在2.18秒内运行（如果添加状态栏更新，则为5.6秒 - 如果只需要2秒，则不需要）

Sub CompareWords2()

    Dim vaNam As Variant, vaMn As Variant
    Dim i As Long, j As Long
    Dim vaSplitNam As Variant, vaSplitMn As Variant
    Dim colUnique As Collection
    Dim lWord As Long
    Dim sLog As String
    Dim lMatches As Long, lTotal As Long
    Dim sgStart As Single

    sgStart = Timer

    'Put both ranges in an array
    With ThisWorkbook.Sheets("Sh1")
        vaMn = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp)).Value
    End With

    With ThisWorkbook.Sheets("Sh2")
        vaNam = .Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)).Value
    End With

    For i = LBound(vaMn, 1) To UBound(vaMn, 1)
        For j = LBound(vaNam, 1) To UBound(vaNam, 1)
            'put all the first words in a collection
            vaSplitMn = Split(vaMn(i, 1), Space(1))
            Set colUnique = New Collection
            For lWord = LBound(vaSplitMn) To UBound(vaSplitMn)
                colUnique.Add vaSplitMn(lWord), LCase(CStr(vaSplitMn(lWord)))
            Next lWord

            'add all the next words to the collection to remove duplicates
            vaSplitNam = Split(vaNam(j, 1), Space(1))
            For lWord = LBound(vaSplitNam) To UBound(vaSplitNam)
                On Error Resume Next
                    colUnique.Add vaSplitNam(lWord), LCase(CStr(vaSplitNam(lWord)))
                On Error GoTo 0
            Next lWord

            'Write to log
            lMatches = UBound(vaSplitMn) + UBound(vaSplitNam) + 2 - colUnique.Count
            lTotal = UBound(vaSplitMn) + 1
            If lMatches >= lTotal / 2 Then
                sLog = sLog & "(#" & i & " Sh1) (#" & j & " Sh2): |" & vaMn(i, 1) & "| - |" & vaNam(j, 1) & "| = "
                sLog = sLog & lMatches & "/" & lTotal & " matches." & vbNewLine
            End If
        Next j
    Next i

    'post total log all at once
    Open ThisWorkbook.Path & Application.PathSeparator & "CompareLog2.txt" For Output As #1
    Print #1, sLog
    Close #1

    Debug.Print Timer - sgStart

End Sub

Answer 2

此site提供了改善效果的好方法。在您的情况下，避免循环细胞;相反，将内容存储在数组中并循环遍历数组。这应该会显着提高性能。

代码的开头看起来像这样（我已经注释掉了原始代码）：

Dim sheet1 As Variant
Dim sheet2 As Variant

With Sheets("Sh1")
  sheet1 = .Range(.Cells(1, 2), .Cells(maxMn, 2))
End With
With Sheets("Sh2")
  sheet2 = .Range(.Cells(1, 6), .Cells(maxNm, 6))
End With

For i = 2 To maxMn 'loop 1
    'Sheets("Sh1").Select
    'Cells(i, 2).Select
    'mnStr = Cells(i, 2).Value
    mnStr = sheet1(i, 1)
    mnArr = Split(mnStr, " ")

    x = 2
    For x = 2 To maxNm 'loop 2
        numTotal = 0
        numMatches = 0
        'Sheets("Sh2").Select
        'Cells(x, 6).Select
        'nameStr = Cells(x, 6).Value
        nameStr = sheet2(x, 1)
        nameArr = Split(nameStr, " ")
        For Each mn In mnArr 'loop 3

您也可以改进文件输出：

Dim i As Long
Dim fileName As String
Dim fileContent As String

i = FreeFile
fileName = "xxxxxx"
fileContent = "yyyyyyy" 'you can call your main function here and return a string
If Dir(fileName) <> "" Then Kill (fileName) 'If you want to override existing file
Open fileName For Binary Lock Read Write As #i
Put #i, , fileContent

Answer 3

这是一个提高效率的指针列表

不要访问循环内的单元格。使用vals = Range("A2").Resize(N,1).Value属性将单元格分配到数组变量中，并使用vals(i,j)访问值。最后，您可以使用Range("A2").Resize(N,1).Value = vals
不要在循环内逐行写入文件。写入字符串，然后在一次操作中将整个字符串写入文件
通过写入状态栏和进度条，最小化更改屏幕的用途。要么使用Application.ScreenUpdating = False关闭更新，要么省略代码。如果需要，可能只有每100次迭代，例如更新UI。

请查看this答案，了解如何有效地使用.Value同时读取和写入多个单元格的示例。

通过嵌套for循环提高效率数组比较

3 个答案: