Я хотел бы использовать VBA, чтобы создать новую таблицу из данных в другой таблице, которая включает только строки определенных критериев.

Question

Я использовал этот код, и он будет работать, когда у меня есть указанная c дата для MaxDate, но не тогда, когда я попытаюсь использовать формулу = TODAY (). Есть идеи?

Sub DepartmentSearch ()

Department = "IT"
MaxDate = "=TODAY()"

Set rng = ActiveSheet.UsedRange  ' source table
rng.AutoFilter Field:=13, Criteria1:=Department  ' filter Department
ActiveSheet.UsedRange.AutoFilter Field:=8, Criteria1:="<" & MaxDate  ' filter date
rng.Copy  ' copy filtered rows
Range("Z2").Select ' source table
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False  ' paste values to target table
rng.AutoFilter ' turn off filter on source table

End Sub

Answer 1

Этот код должен работать:

Sub FruitSearch()
    NewTblRow = 2  ' target table
    NewTblCol = 6
    Fruit = "Apples"
    MaxDate = DateValue("8/1/2020")

    Set Rng = Range("A2:B500")  ' source table
    
    'copy column names
    Cells(NewTblRow, NewTblCol) = Rng(1, 1)
    Cells(NewTblRow, NewTblCol + 1) = Rng(1, 2)
    
    ctr = NewTblRow + 1
    For r = 1 To Rng.Rows.Count  ' each row in source table
       If Rng(r, 1).Value = Fruit And Rng(r, 2).Value < MaxDate Then ' check string and date
          Cells(ctr, NewTblCol) = Rng(r, 1)  ' copy string
          Cells(ctr, NewTblCol + 1) = Rng(r, 2)  ' copy date
          ctr = ctr + 1  ' next row in target table
       End If
    Next
End Sub

Как упоминал @BigBen, для нас уже есть колесо. И я узнал:)

Sub FruitSearch2()
    Fruit = "Apples"
    MaxDate = "8/1/2020"

    Set Rng = Range("A2:B500")  ' source table
    Rng.AutoFilter Field:=1, Criteria1:=Fruit  ' filter fruit
    ActiveSheet.Range("A2:B500").AutoFilter Field:=2, Criteria1:="<" & MaxDate  ' filter date
    Rng.Copy  ' copy filtered rows
    Range("F2").Select ' source table
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False  ' paste values to target table
    Rng.AutoFilter ' turn off filter on source table
End Sub