CODEWITHSUNDEEP
excelvba
user13842516
user13842516

Reputation:

I would like to use VBA to be able to create a new table from data in a different table that only includes rows of certain criteria

I used this code, and it will work when I have a specific date for MaxDate, but not when I try and use the =TODAY() formula. Any ideas?

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

Upvotes: 0

Views: 42

Answers (1)

Mike67
Mike67

Reputation: 11342

This code should work:

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

As @BigBen mentioned, there's a wheel available for us already. And I gotsta know :)

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

Upvotes: 1

Related Questions