Как заставить несколько операторов for работать эффективно в VBA - PullRequest
Новая
       16

Как заставить несколько операторов for работать эффективно в VBA

0 голосов
/ 09 апреля 2019

В моем коде есть порядок поиска, и он выглядит следующим образом:

Он принимает каждое значение (около 2000 диапазонов) в диапазоне ws.sheet A и ищет его на другом листе с именем wp.sheet range A (около 90 диапазонов). Если конкретное значение x в диапазоне ws.sheet, например, A3, не найдено в диапазоне wp.sheet A, следующим порядком поиска в листе ws.sheet будет значение y в следующем диапазоне B3 (в той же строке, что и значение x), в котором нужно искать в лист wp.sheet во всем диапазоне B и так далее.

Это то, что делает мой цикл for, и проблема с моим кодом состоит в том, что он занимает очень много времени, поскольку он сравнивает каждое значение в диапазоне ws.sheet A1-2000 со значениями в диапазоне wp.sheet A1-90. Есть ли альтернатива, которая делает это быстрее или эффективнее? 

Dim wb As Workbook, wq As Object
Dim ws, wi As Worksheet, datDatum
Dim w As Long, I As Long, t As Long
Dim DefaultMsgBox()
Dim r, i As Integer    



For r = 2 To 2000

Check = True:

For i = 1 To 90
    If ws.Range("A" & r).Value = wp.Sheets("ABC").Range("A" & i).Value Then
       wp.Sheets("ABC").Rows(i).Columns("E:AB").Copy
       ws.Range("G" & r).PasteSpecial
       GoTo NextR
    End If
Next i

For i = 1 To 90
     If ws.Range("B" & r).Value = wp.Sheets("ABC").Range("B" & i).Value Then
        wp.Sheets("ABC").Rows(i).Columns("E:AB").Copy
        ws.Range("G" & r).PasteSpecial
        GoTo NextR
     End If
Next i

For i = 1 To 90
     If ws.Range("C" & r).Value = wp.Sheets("ABC").Range("C" & i).Value And ws.Range("D" & r).Value = wp.Sheets("ABC").Range("D" & i).Value Then
        wp.Sheets("ABC").Rows(i).Columns("E:AB").Copy
        ws.Range("G" & r).PasteSpecial
        GoTo NextR
     End If
 Next i

NextR:
    If Not Check = ws.Range("A" & r).Value = wp.Sheets("ABC").Range("A" & i).Value Or Not Check = ws.Range("B" & r).Value = wp.Sheets("ABC").Range("A" & i).Value Or Not Check = ws.Range("C" & r).Value = wp.Sheets("ABC").Range("C" & i).Value And ws.Range("D" & r).Value = wp.Sheets("ABC").Range("D" & i).Value Then
    MsgBox "......"
    End If
Next r
End sub

Ответы [ 2 ]

1 голос
/ 09 апреля 2019

Я бы предложил отключить ScreenUpdating и использовать вместо него функцию Find: 

Dim cell, foundValue, lookupRange As Range

Set wp = ThisWorkbook.Sheets("ABC")
Set ws = ThisWorkbook.Sheets("WS")

r = 2
number_r = 2000
ru = 1
number_ru = 90

Application.ScreenUpdating = False

'Loop through each cell in WS, offsetting through columns A to C
For Each cell In ws.Range("A" & r & ":A" & number_r)
    For i = 0 To 2

        'Define range to look up in ABC
        Set lookupRange = wp.Range(wp.Cells(ru, i + 1), wp.Cells(number_ru, i + 1))

        'Look for current WS cell on corresponding column in ABC
        Set foundValue = lookupRange.Find(cell.Offset(0, i).Value)

        'If cell is found in ABC...
        If Not foundValue Is Nothing Then
            Select Case i
            Case 2 'If found cell is in column C

                Do 'Lookup loop start

                'If same values on columns D...
                If foundValue.Offset(0, 1).Value = cell.Offset(0, 3).Value Then

                    'Copy data to WS and switch to the next cell
                    wp.Rows(foundValue.Row).Columns("E:AB").Copy
                    ws.Range("G" & cell.Row).PasteSpecial
                    GoTo nextCell

                'If not same values on columns D...
                Else

                    'Try to find next match, if any
                    Set foundValue = lookupRange.FindNext(foundValue)
                    If foundValue Is Nothing Then GoTo noMatchFound

                End If

                Loop 'Repeat until WS values in column C and D match ABC values in columns C and D

            Case Else 'If found cell is in column A or B

                'Copy data to WS and switch to the next cell
                wp.Rows(foundValue.Row).Columns("E:AB").Copy
                ws.Range("G" & cell.Row).PasteSpecial
                GoTo nextCell

            End Select

        End If
    Next i
noMatchFound:
    MsgBox "......" 'Message appears only when no match was found in column A, column B and column C + D
nextCell:
Next cell

Application.ScreenUpdating = True
0 голосов
/ 09 апреля 2019

Надеюсь, вы не возражаете против моего высказывания, но ваш код сложен для понимания, включая ваш выбор имен переменных. Я могу порекомендовать вам, если вы не используете свои операторы .copy, закомментируйте их, и ваш код будет работать намного быстрее.

...