VBA多个循环匹配条件

VBA多个循环匹配条件

本文介绍了VBA多个循环匹配条件的处理方法,对大家解决问题具有一定的参考价值,需要的朋友们下面随着小编来一起学习吧!

问题描述

我很抱歉,如果这是重复的,因为我一直在搜索,没有找到答案。我是VBA的新手,以及它们的循环结构。我正在搜索和比较。我需要比较第一行中的值,看看它们是否匹配第二行,如果不是,则继续移动到下一行。看到我的下面的代码(它运行没有错误,只是没有找到任何存在的值,我可以手动搜索它找到它们)



这个数据集可能是真的大,所以我想尽可能高效地写这个,我不知道什么循环结构将执行得更快。我需要比较第21列中的值,看看是否有重复的值,如果有,那么我需要看看相应行的列22中的值是否相同,如果是,我想去RowB中的下一行,否则如果它们不是相同的值,那么我想检查第4行中两个日期的值,并查看它们是否在彼此之后的两个月内。如果他们不继续寻找。

  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
尽管RowA< = RowsCount
GroupA = Cells(RowA, 21).Value
CounterA = Cells(RowA,22).Value
RevDateA = Cells(RowA,4).Value
Do While RowB GroupB = Cells (RowB,21).Value
CounterB = Cells(RowB,22).Value
RevDateB = Cells(RowB,4).Value
如果GroupA = GroupB Then
如果CounterA = CounterB然后在B中下一行,并重复
Else
如果RevDateB - RevDateA& LT; 62然后
'突出显示行b并移动
行(RowB)。选择
Application.CommandBars.ExecuteMsoCellFillColorPicker
Else
End If
结束如果
否则在B中下降1行并重复检查
如果

RowB = RowB + 1
循环

RowA = RowA + 1
循环


解决方案

加快代码的方法不是在优化循环中,而是改变访问Excel数据的方式。总是参考单元格比将范围转换为数组和枚举数组要慢得多。



更多详细信息:



所以在你的例子中,你可以先将 Range 转换为 Array 然后枚举阵列。这是您的代码转换为使用数组(2个数组 - 一个用于组和计数在列U和V,第二个列D中的日期 - 添加了一些注释)

  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'这里定义组和计数的范围 - 列U和V
rangeDates =D1:D& RowsCount'这里定义日期的范围 - 列D
Arr =范围(rangeDefinition)'这里将组和计数转换为数组
ArrDates = Range(rangeDates)'这里将数据转换为数组

RowA = 2
RowB = 3
尽管RowA< = RowsCount
尽管RowB< = RowsCount
如果Arr(RowA,1)= Arr(RowB, 1)然后'比较U列 - 组
如果Arr(RowA,2)= Arr(RowB,2)然后'比较V列 - 计数 - >在B中下行1行并重复
Else
如果ArrDates(RowB,1) - ArrDates(RowA,1) 62然后
'检查日期 - 列D - >突出显示行b并移动
行(RowB)。选择
Application.CommandBars.ExecuteMsoCellFillColorPicker
Else
End If
End If
Else在B中下一行并重复检查
结束If
RowB = RowB + 1
循环
RowA = RowA + 1
循环


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
解决方案

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

这篇关于VBA多个循环匹配条件的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持!

08-14 23:34