VBA Multiple loops match conditions

问题:

I apologize if this is a duplicate as I have been searching and haven't found an answer. I am new to VBA and how they structure loops. I am trying to do a search and compare. I need to compare the values in the first row to see if they match the second row and if not then keep moving on to the next row. See my code below (it runs without error just doesn't find any values that do exist as I can search it manually and find them)

This data set could be really large so I want to write this as efficiently as possible and am not sure what loop structures will execute faster. I need to compare the value in column 21 and see if if there is a duplicate value, if there is then I need to see if the values in column 22 of the respective rows are the same and if they are then I want to go to the next row in RowB otherwise if they are not the same value then I want to check the values in row 4 that are both dates and see if they are within 2 months of each other. If they are not keep looking.

Dim RowsCount As Integer
Dim ColCount As Integer
RowsCount = Cells(Rows.Count, 1).End(xlUp).Row
ColCount = Cells(1, Columns.Count).End(xlToLeft).Column

Dim RowA As Integer
Dim RowB As Integer
Dim GroupA As Variant
Dim GroupB As Variant
Dim CounterA As Variant
Dim CounterB As Variant
Dim RevDateA As Date
Dim RevDateB As Date
Dim RevDateDiff As Variant

RowA = 2
RowB = 3
Do While RowA <= RowsCount
GroupA = Cells(RowA, 21).Value
CounterA = Cells(RowA, 22).Value
RevDateA = Cells(RowA, 4).Value
    Do While RowB <= RowsCount
    GroupB = Cells(RowB, 21).Value
    CounterB = Cells(RowB, 22).Value
    RevDateB = Cells(RowB, 4).Value
        If GroupA = GroupB Then
            If CounterA = CounterB Then 'go down 1 row in B and repeat
            Else
                If RevDateB - RevDateA < 62 Then
                'highlight row b and move on
                Rows(RowB).Select
                Application.CommandBars.ExecuteMso "CellFillColorPicker"
                Else
                End If
            End If
        Else 'go down 1 row in B and repeat check
        End If

    RowB = RowB + 1
    Loop

RowA = RowA + 1
Loop

回答1:

This is a pretty good way to find row to row dupes

Private Sub findit()

Dim bringIn As Variant

bringIn = ThisWorkbook.Sheets("Sheet1").UsedRange
rowC = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count

For i = LBound(bringIn, 1) To UBound(bringIn, 1)
    If i = rowC Then
        'nothing
    Else
        If bringIn(i, 1) = bringIn(i + 1, 1) Then
            ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Interior.ColorIndex = 37
        End If
    End If
Next i

End Sub

回答2:

The best way to speed up your code is not in optimizing loops but changing way how you are accessing Excel data. Always referring Cells is much slower than converting ranges to arrays and enumerating arrays instead.

More details here: Arrays And Ranges In VBA

So in your example you can convert Range to Array first and then enumerate Array. Here is your code converted to use array (2 arrays - one for groups and counts in columns U and V, second for dates in column D - Added some comments)

Dim RowsCount As Long
Dim RowA As Long
Dim RowB As Long
Dim Arr() As Variant
Dim ArrDates As Variant
Dim rangeDefinition As String
Dim rangeDates As String

    RowsCount = Cells(Rows.Count, 1).End(xlUp).Row

    rangeDefinition = "U1:V" & RowsCount ' Here define range for groups and counts - columns U and V
    rangeDates = "D1:D" & RowsCount ' Here define range for dates - column D
    Arr = Range(rangeDefinition) ' Here convert groups and counts to array
    ArrDates = Range(rangeDates) ' Here convert dates to array

    RowA = 2
    RowB = 3
    Do While RowA <= RowsCount
        Do While RowB <= RowsCount
            If Arr(RowA, 1) = Arr(RowB, 1) Then ' Compare U column - groups
                If Arr(RowA, 2) = Arr(RowB, 2) Then ' Compare V column - counts -> go down 1 row in B and repeat
                Else
                    If ArrDates(RowB, 1) - ArrDates(RowA, 1) < 62 Then
                    ' Check dates - Column D -> highlight row b and move on
                    Rows(RowB).Select
                    Application.CommandBars.ExecuteMso "CellFillColorPicker"
                    Else
                    End If
                End If
            Else 'go down 1 row in B and repeat check
            End If
        RowB = RowB + 1
        Loop
    RowA = RowA + 1
    Loop