Excel VBA, Autofilter with the output from a loop

Question

Sub Projektlaufzeit()

Dim Datum1 As Date, msg As String
Dim Datum2 As Date
Dim Rest As Long
Dim Projektname As String
Dim i As Integer
Dim c As Integer
Dim ber As Range


Projektname = Range("A2")
Datum1 = Date
'Datum2 = Tabelle1.Range("C2")


c = Sheets("tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Column

For i = 2 To c

Projektname = Cells(i, 1)
Datum2 = Cells(i, 3)
Rest = DateDiff("d", Datum1, Datum2)


    If Rest > 7 And Rest < 30 Then MsgBox "something"
    If Rest >= 0 And Rest <= 7 Then MsgBox "something"
    If Rest <= 0 Then MsgBox "something"

Next i


Dim FilterArray
Dim List As Range
Set List = ActiveSheet.Range("A:A")

List.AutoFilter
FilterArray = Array(Projektname)

List.AutoFilter Field:=1, Criteria1:=Array(FilterArray)


End Sub

So that is my code so far. I have a Loop which tells me when a certain project will come to an end. That works so far. The next step is, that the macro will autofilter all projects that have a remaining duration of < 30 days.

In my code obviously only the last project that was affected by the loop will be filtered. Is it possible to create an array with all affected projects? I attached a screenshot of the Excel Worksheet. Thanks in advance.

Answer 1

If you imagine that all your dates are numbers and your target is to create an array of the values in column A, that correspond to some condition, then this is a possible input:

With the code below, the condition is translated as: Projects with remaining duration less or equal than 2 days and not finished with today's date.

Option Explicit

Sub ProjectTime()

    Dim lngDateToday            As Long
    Dim lngRemainingDuration    As Long
    Dim lngLastRow              As Long
    Dim lngCounter              As Long
    Dim varProjects()           As Variant
    Dim blnFirst                As Boolean

    blnFirst = True
    lngDateToday = Range("D2")
    lngRemainingDuration = Range("E2")
    lngLastRow = 13
    ReDim varProjects(0)

    For lngCounter = 2 To lngLastRow
        If Cells(lngCounter, 3) < (lngDateToday + lngRemainingDuration) And _
                                Cells(lngCounter, 3) >= lngDateToday Then

            If Not blnFirst Then
                ReDim Preserve varProjects(UBound(varProjects) + 1)
            End If
            blnFirst = False
            varProjects(UBound(varProjects)) = Cells(lngCounter, 1)
        End If

    Next lngCounter

    For lngCounter = LBound(varProjects) To UBound(varProjects)
        Debug.Print varProjects(lngCounter)
    Next lngCounter

End Sub

Thus, projects E,G and I (highlighted) are the one matched and added to the array of values. As far as we are not using a collection, but an array, I am redim-ing and preserving on every step (except for the first one).

To filter the array, you need to add the array as a parameter to the filter. Add the following to the end of the code:

Dim List As Range
Set List = ActiveSheet.Range("A:A")
List.AutoFilter
List.AutoFilter field:=1, Criteria1:=Array(varProjects), Operator:=xlFilterValues

This is how it should look like: