如果在VBA中没有选择，我如何循环2个或更多变化的变量？

Question

我很难解决问题。我刚刚开始编码，我想创建一个宏来检查3个变量（1个用于日期，2个用于位置），而不使用Selection函数。

我想要实现的是让一个单元格用一个日期（A）检查1个单元格，以确定日期是否在今天之前，以及该单元格是否为空白。它会写“过期”（如果日期在今天之前）或左侧单元格中的文本。

然后它将移动到下面的单元格并再次执行此操作。尽管这很有效，但速度非常慢，我想知道是否还有其他方法可以用来加快速度（8000线这真的不值得）。也许使用过滤器？

任何帮助深表感谢！

Dim status As String
Dim exp As Date
Dim i As Integer
Dim n As Integer
Dim m As Integer


i = 0
n = 1
status = 1
m = 1

Do While status <> ""

    Cells.Find(What:="A", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    ActiveCell.Offset(n, 0).Select

    exp = Selection

    Cells.Find(What:="B", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate

   ActiveCell.Offset(m, 0).Select



    status = ActiveCell.Offset(i, -1).Value

    MsgBox (status)

    If exp <> 0 And exp < Date Then
        ActiveCell.FormulaR1C1 = "Expired"
    Else
        ActiveCell.FormulaR1C1 = status
    End If

    i = i - 1
    n = n + 1
    m = m + 1

Loop

Example

编辑：我认为这或多或少以简单的方式显示了我想做的事情。目的是仅在日期之前更改状态文本。但是，可能会有其他列（如Amount），所以我想避免静态范围，如果是25000行，则选择方法是VERRRY慢。我确实觉得我已经过分复杂了。

Answer 1

我想出了一些更适合你提出的案例的编码：

它将在新工作簿上设置一些测试数据，并且没有列地址是硬编码的。

它还将展示如何创建一个listobject并以面向对象的方式引用其各种元素，而无需硬编码地址

最后，它使用listobject的过滤功能来执行过滤（它与基于表单的自动过滤器大致相同）

运行Main（）子程序以启动演示。

Const COL_FRUIT As String = "Fruit", COL_FRESHUNTIL As String = "Fresh Until", COL_STATUSTEXT = "Status text"
Dim POS_FRUIT As Integer, POS_FRESHUNTIL As Integer, POS_STATUSTEXT As Integer


Sub Main()
    Dim lo As ListObject
    SetupData lo
    lo.ListColumns(COL_FRUIT).Range.Select
    MsgBox "Fruit column"

    lo.ListRows(2).Range.Select
    MsgBox "2nd row"

    lo.ListColumns(COL_FRUIT).DataBodyRange.Select
    MsgBox "Fruit data"

    lo.Range.AutoFilter Field:=POS_FRESHUNTIL, Criteria1:= _
        "<4/1/2018", Operator:=xlAnd
    lo.Range.AutoFilter Field:=POS_STATUSTEXT, Criteria1:= _
        "=*exp*", Operator:=xlAnd

    MsgBox "Filter applied: " & vbCrLf & _
    "Row 1 matched: " & (lo.ListRows(1).Range.Height <> 0) & vbCrLf & _
    "Row 2 matched: " & (lo.ListRows(2).Range.Height <> 0) & vbCrLf & _
    "Row 3 matched: " & (lo.ListRows(3).Range.Height <> 0)
End Sub
Sub SetupData(ByRef ref_lo As ListObject)
    Dim newwb As Workbook, currsh As Worksheet, vData As Variant, rData As Range, lo As ListObject
    Set newwb = Workbooks.Add
    Set currsh = newwb.Worksheets(1)
    Dim s As String
    vData = [{"Fruit", "Fresh Until", "Status text"; "Apple","03-03-2018","Fresh";"Apple","03-12-2017","Expired";"Apple","03-12-2017","Date over"}]
    POS_FRUIT = GetColPos(COL_FRUIT, vData)
    POS_FRESHUNTIL = GetColPos(COL_FRESHUNTIL, vData)
    POS_STATUSTEXT = GetColPos(COL_STATUSTEXT, vData)        

    Set rData = currsh.Cells(1).Resize(UBound(vData, 1), UBound(vData, 2))
    rData = vData
    Set ref_lo = currsh.ListObjects.Add(xlSrcRange, rData, , xlYes)     ' or ListObjects("name_of_your_listobject")        

End Sub

Function GetColPos(sCol As String, data As Variant) As Integer
    Dim ifr As Integer, ito As Integer, i As Integer
    ito = UBound(data, 2)
    ifr = LBound(data, 2)
    For i = ifr To ito
        If sCol = data(LBound(data, 1), i) Then
            GetColPos = i
            Exit Function
        End If
    Next

     GetColPos = -1

End Function

Answer 2

您可以将范围对象的所有值都捕获到2d数组变量，然后您可以使用该数组。它的速度快得多

例如。假设你在a1：c6范围内有许多不同的值，你需要循环通过这些值

Dim var2d As Variant, r As Range
Set r = ActiveSheet.Range("A1:C6")
var2d = r   ' var2d becomes a 6x3 array
Msgbox var2d(2,1) ' print value of cell A2
var2d(3,2) = "Expired"
var2d(5,1) = 123
r.Value = var2d  ' write the modified array back to a1:c6

Answer 3

你可以这样做

Dim status As String
Dim exp As Date
Dim i As Integer
Dim n As Integer
Dim m As Integer

Dim c As Range, d As Range

i = 0
n = 1
status = 1
m = 1

With ActiveSheet
    Set d = .Range("A1")
    Do While status <> ""
        Set c = .Cells.Find(what:="A", after:=d, LookIn:=xlFormulas _
                , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
        If Not c Is Nothing Then
            exp = c.Offset(n, 0).Value2
            Set d = .Cells.Find(what:="B", after:=c.Offset(n, 0), LookIn:=xlFormulas _
                    , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)
            If Not d Is Nothing Then
                With d.Offset(m + i, -1)
                    .Select
                    status = .Value2
                    MsgBox status

                    If exp <> 0 And exp < Date Then
                        .Value2 = "Expired"
                    Else
                        .Value2 = status
                    End If
                End With
            End If
        End If

        i = i - 1
        n = n + 1
        m = m + 1
    Loop
End With