Повышение эффективности с помощью вложенных циклов и сравнений массивов

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

Этот сайт имеет хорошие советы по улучшению производительности.В вашем случае избегайте зацикливания на ячейках;вместо этого сохраните содержимое в массиве и зациклите массив.Это должно значительно повысить производительность.

Начало вашего кода будет выглядеть следующим образом (я закомментировал ваш исходный код):

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

Вот список указателей, чтобы сделать это более эффективным

1. Не обращаться к ячейкам внутри цикла.Присвойте ячейки переменной массива с помощью свойства vals = Range("A2").Resize(N,1).Value и получите доступ к значениям с помощью vals(i,j).В конце вы можете записать значения обратно в электронную таблицу с помощью Range("A2").Resize(N,1).Value = vals
2. Не записывать в файл построчно внутри цикла.Записать в строку, а затем записать всю строку в файл за одну операцию
3. Свести к минимуму использование, меняющее экран, записывая строки состояния и индикаторы выполнения.Либо отключите обновления с помощью Application.ScreenUpdating = False, либо просто пропустите код.При необходимости, возможно, только каждую сотую итерацию, например, обновите пользовательский интерфейс.

Посмотрите на этот ответ для примера того, как использовать .Value для чтения и записи в несколькоклетки в то же время эффективно.