Selecting filtered dates from a VBA FORM to run in an AutoFilter macro

[Rabbitoh]

I hope someone can help me. My problem is two-fold:

1. Using two drop-down boxes on a FORM, I want to be able to firstly, select a start DATE (e.g. 22/01/2009) from one box, and an end DATE (e.g. 22/03/2009) from the other box, where both drop-down box fields reference a column listing of DATES on a worksheet, which in turn contains multiples of the same DATES i.e. the dates in the column listing are not unique so I need them filtered down to one of each (i.e. not displaying any duplicates) for selection from the drop-down boxes.

When saved, the FORMS drop-down box DATE selections then get copied to two different cells on another worksheet (this I can already do)

2. I need to then have the two DATES contained in the cells in the worksheet (that were copied from the above FORM selections), referenced in an AutoFilter procedure in a macro.

This how the macro entry would look if the two dates were static and if I filtered them manually using the Custom function of AutoFilter directly in the worksheet:

' Selection.AutoFilter Field:=2, Criteria1:=">=22/01/2009", Operator:=xlAnd _
' , Criteria2:="<=22/03/2009"

However, my dates will be variables (based on the selections I want to make from my drop-down boxes) so I have tried the following but neither work (and neither allows me to take into account the “>=” and “<=” prefixes):

TW = Worksheets("Report").Range("B4")
TW1 = Worksheets("Report").Range("B5")
Selection.AutoFilter Field:=2, Criteria1:=TW, Operator:=xlAnd _
, Criteria2:=TW1

or

Selection.AutoFilter Field:=2, Criteria1:=ThisWorkbook.Worksheets("Report").Range("B4").Value, Operator:=xlAnd _
, Criteria2:=ThisWorkbook.Worksheets("Report").Range("B5").Value


When run, the results of the macro AutoFilter procedure “should” then filter to display all column entries (including all DATE duplicates) that are equal to and greater then/equal to and less than, the two DATES originally selected in the two drop-down boxes on the FORM.

 

[HaHoBe]

Hi,

try this code:

    Selection.AutoFilter Field:=2, _
        Criteria1:=">" & CDbl(DateValue(Worksheets("Report").Range("B4").Text)), _
        Operator:=xlAnd, _
        Criteria2:="<" & CDbl(DateValue(Worksheets("Report").Range("B5").Text))

Ciao,
Holger

 

[Rabbitoh]

Excellent, needed to add the "=" on both criteria though to work it.

Selection.AutoFilter Field:=2, _
Criteria1:=">=" & CDbl(DateValue(Worksheets("Report").Range("B4").Text)), _
Operator:=xlAnd, _
Criteria2:="<=" & CDbl(DateValue(Worksheets("Report").Range("B5").Text))

Thank you - the code looks so simple once you see the experts do it!

Leaving the post open pending help on the first the first part of the post (filtered date selections)

Terry

 

[HaHoBe]

Hi, Terry,

maybe use the code from ErlandsenData:

Option Explicit
Option Base 1

Function FINDUNIQUE(InputRange As Variant, SortMode As Integer, Transp As Boolean) As Variant
' returns an array containing all the unique values in InputRange
' SortMode=0 : no sorting  SortMode=1 : sort ascending  SortMode=-1 : sort descending
' Transp=False returns a horisontal array, Transp=True returns a vertical array
' assumes Option Base 1
' works in all Excel-versions
Dim i As Long, j As Long, tValue As Variant
Dim uValues() As Variant, cU As Long, vFound As Boolean
Dim cRow As Long, cCol As Integer, r As Long, c As Integer
    FINDUNIQUE = "#N/A!"
    If InputRange.Cells.Count < 1 Then Exit Function
    cU = 1
    Erase uValues
    ReDim uValues(cU)
    uValues(cU) = InputRange.Cells(1, 1).Value
    cRow = InputRange.Rows.Count
    cCol = InputRange.Columns.Count
    For r = 1 To cRow
        For c = 1 To cCol
            vFound = False
            i = 0
            While Not vFound And i < cU
                i = i + 1
                If uValues(i) = InputRange.Cells(r, c).Value Then vFound = True
            Wend
            If Not vFound Then
                cU = cU + 1
                ReDim Preserve uValues(cU)
                uValues(cU) = InputRange.Cells(r, c).Value
            End If
        Next c
    Next r
    
    If SortMode <> 0 Then ' perform sorting
        For i = 1 To cU - 1
            For j = i + 1 To cU
                vFound = True
                If SortMode = -1 Then ' sort descending
                    If uValues(i) < uValues(j) Then vFound = False
                Else  ' sort ascending
                    If uValues(i) > uValues(j) Then vFound = False
                End If
                If Not vFound Then
                    tValue = uValues(i)
                    uValues(i) = uValues(j)
                    uValues(j) = tValue
                End If
            Next j
        Next i
    End If
        
    FINDUNIQUE = uValues
    If Transp Then FINDUNIQUE = Application.Transpose(FINDUNIQUE)
    Erase uValues
End Function

Ciao,
Holger

 

[Rabbitoh]

Gidday, can you please tell me where I would place this code in the sub routine.

 

[HaHoBe]

Hi, Terry,

I´d used that routine for a list and then run the rest. Please find a small sample just looping through the dates in Column A:

Private Sub FindUniqueItems(UniqueItems As Variant, FilterRange As String)
' returns a list containing all unique items in the filter range
    Dim TempList() As String
    Dim UniqueCount As Integer
    Dim cl As Range
    Dim i As Integer
    Range(FilterRange).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    UniqueCount = Range(FilterRange).SpecialCells(xlCellTypeVisible).Count
    ReDim TempList(1 To UniqueCount - 1)
    i = 0
    For Each cl In Range(FilterRange).SpecialCells(xlCellTypeVisible)
        i = i + 1
        If i > 1 Then TempList(i - 1) = cl.Formula ' ignore the heading
    Next cl
    Set cl = Nothing
    UniqueItems = TempList
End Sub

Sub FilterToCheck()
'Idea: ERLANDSEN DATA CONSULTING, http://www.erlandsendata.no/downloads/filterandprint.zip
Dim ItemList As Variant
Dim i As Integer
Dim rngcell As Range
Dim lngCounter As Long

Const cstrAREA As String = "A1:A23"

Application.ScreenUpdating = False
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
FindUniqueItems ItemList, cstrAREA

Range(cstrAREA).AutoFilter
For i = 1 To UBound(ItemList)
    Range(cstrAREA).AutoFilter 1, CDate(ItemList(i))
    'more code here
    Application.Wait Now + TimeSerial(0, 0, 2)
Next i

Application.ScreenUpdating = True
With ActiveSheet
    .ShowAllData
    .AutoFilterMode = False
End With

End Sub

Ciao,
Holger

 

[Rabbitoh]

Sorry but I simply cannot get the above code to work.

I have tried two different ways.

Firstly I tried through a UserForm (UserForm1). I added the suggested code to a Private Sub control routine as follows:

Private Sub ComboBox1_Change()
(code was added here)
End Sub

When I couldn’t get this to work I tried using a DialogSheet with two Drop Down boxes, both with the necessary Control input range of: Sheet1!$B$5:$B$4008 (which is the range I need both selection boxes to filter the content on), along with the supporting Module code of:

Sub NewDateSelect()

With DialogSheets("FormAdd")
.DropDowns("Drop Down 15").ListIndex = 0
.DropDowns("Drop Down 16").ListIndex = 0
.Show
End With

End Sub

I then saved the Sub Routine code “FilterToCheck()” along with the Private Sub code, to a VBA Module and related the macro to the first Drop Down box (15) and tested.

Again, regardless of how much I played around with the permutations, I simply could not get any content to display at all from the Drop Downs on the DialogSheet.

Can I please have some help on how to relate this code using either of the above approaches (UserForm or DialogSheet), in order to get it to work.

Terry

 

[HaHoBe]

Hi, Terry,

can you please attach a sample of your workbook to have a look at it?

Ciao,
Holger

 

[Rabbitoh]

Attached. have gutted it a bit to reduce its size and removed links to external document but it still works.

 

[HaHoBe]

Hi, Terry,

sorry for the late answer. I changed the Userform to show the uniques from a slightly modified worksheet CRSUM. To apply the autofilter in sheet CRSUM please use the button. Closing the Form at present is only possible via the X:

Option Explicit
'Option Base 1

Private Sub cmdApplyAutoFilter_Click()

If ComboBox1.ListIndex < 0 Or ComboBox2.ListIndex < 0 Then
  Unload Me
  Exit Sub
End If
Sheets("CRSUM").Activate
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False

With Range("A4:G4")
    .AutoFilter
    .AutoFilter Field:=2, _
        Criteria1:=">=" & CLng(DateValue(ComboBox1.Text)), _
        Operator:=xlAnd, _
        Criteria2:="<=" & CLng(DateValue(ComboBox2.Text))
End With

Unload Me

End Sub

Private Sub CommandButton1_Click()
'Call SaveDateSelect
End Sub

Private Sub CommandButton2_Click()
'Call HideDateSelect
End Sub


Private Sub UserForm_Activate()
'Idea: ERLANDSEN DATA CONSULTING, http://www.erlandsendata.no/downloads/filterandprint.zip
Dim ItemList As Variant

Application.ScreenUpdating = False
If Sheets("CRSum").AutoFilterMode Then Sheets("CRSum").AutoFilterMode = False
FindUniqueItems ItemList, Sheets("CRSum").Range("B5:B" & Sheets("CRSUM").Cells(Rows.Count, "B").End(xlUp).Row).Address

ComboBox1.List = ItemList
ComboBox2.List = ItemList
End Sub

Private Sub FindUniqueItems(UniqueItems As Variant, FilterRange As String)
' returns a list containing all unique items in the filter range
    Dim TempList() As String
    Dim UniqueCount As Integer
    Dim cl As Range
    Dim i As Integer
    Range(FilterRange).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    UniqueCount = Range(FilterRange).SpecialCells(xlCellTypeVisible).Count
    ReDim TempList(1 To UniqueCount - 1)
    i = 0
    For Each cl In Range(FilterRange).SpecialCells(xlCellTypeVisible)
        i = i + 1
        If i > 1 Then TempList(i - 1) = CDate(cl.Formula) ' ignore the heading
    Next cl
    Set cl = Nothing
    UniqueItems = TempList
    With ActiveSheet
        .ShowAllData
        .AutoFilterMode = False
    End With

End Sub

HTH,
Holger

 

[Rabbitoh]

Thanks for this.

Your test sheet works perfectly and is exactly what I want. When I transfer the userform to my workbook I have to also transfer your CRSUM worksheet to make the form work otherwise it errors out (see below). From that point on it all works fine until I update new data to the CRSUM worksheet.

I use a macro to do this by sequencially copying data from several other worksheets for paste special of values only, appending each set of data to the previous, to CRSUM. Once I have done this the form errors out at:

If i > 1 Then TempList(i - 1) = CDate(cl.Formula) ' ignore the heading

It highlights from TempList onwards as being the error component.

Your CRSUM worksheet and mine are essentially identical (at least visually) as they only contain data - no formulas etc.

What is the form's VBA routine actually doing to the data on CRSUM at this point that makes what is really the same data just refreshed with new data, to error out and how can it be prevented?

This is the code I use to update the data to CRSUM. It repeats the "Do CR1" section for worksheets CR2, CR3, etc through to CR10, appending the data as it goes to the end of the previous.

'First clear the existing filters and data
Selection.AutoFilter
Range("A4:G4").Select
Range("G4").Activate
Selection.AutoFilter
Range("A5:G65536").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("A5").Select

'Do CR1
Sheets("CR1").Select
ActiveSheet.Unprotect
Range("A7").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Application.CutCopyMode = False
Selection.Cut
Application.CutCopyMode = False
Selection.Copy
Range("A7").Select
Sheets("CRSUM").Select
Set Range1 = Worksheets("CRSUM").Range("c5:c10000")
intExistRowNumber = IsRecordExist(Range1)
If intExistRowNumber <> 0 Then
Worksheets("CRSUM").Cells(intExistRowNumber, 1).Select
intNewRowNumber = NewRowNuber(Range1)
End If
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A7").Select

Then it sorts the data as so (which you also help me with previously):

With Range("A5:G" & Cells(Rows.Count, "A").End(xlUp).Row)
.Sort Key1:=Range("B5"), _
Order1:=xlAscending, _
Header:=xlNo, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers
End With

I do not see how this action would cause a problem.

I do appreciate how much effort you have put into this exercise thus far.

Terry