Filter Products Between Two Dates With VBA Userform

The Items Filtering Based On Dates (First-Last Date)

Suppose we have an Excel sheet where we enter the products we purchased .In some cases, we would like to see which product line we bought between certain dates. For this, we need to filter between two dates. We have created a template that we used the userform to filter between two dates on the worksheet.

✓ To select two dates, we used the date userform as an alternative to the VBA calendar-date picker control that opened when we click the textbox. ↴

The date userform consists of two scrollbars, two textboxes and labels. On the textboxes, the month and year can be selected using the scrollbars. A label control was added for each day in the userform. Clicking on the labels, the day is selected and the userform is closed.

We added some code to Module1 to add calendar feature to the date userform and enter the selected date into the textbox, and we created classes in Class Module. Codes of Module1 : ⬇

Public days() As New Class1
Public scrl_bar() As New Class1
Public takvim_txt() As New Class1
Public baslangic_yili
Public bitis
Public aktif_txt

Sub clasa_ekle()
baslangic_yili = 1920 'Minimum  Year in Takvim Userform
bitis = 2100          'Maximum Year in Takvim Userform

ReDim Preserve takvim_txt(2)
Set takvim_txt(1).takvim_txt = UserForm1.TextBox1
Set takvim_txt(2).takvim_txt = UserForm1.TextBox2
End Sub

Codes of Class1 : ⬇

Public WithEvents days As MSForms.Label
Public WithEvents scrl_bar As MSForms.ScrollBar
Public WithEvents takvim_txt As MSForms.TextBox

Private Sub days_Click()
On Error Resume Next

If days = "" Then Exit Sub
If days.Name = "bugün" Then
aktif_txt.Text = VBA.Format(Now, "dd.mm.yyyy")
ElseIf days <> "" Then
aktif_txt.Text = DateSerial(Userform_Date.ScrollBar1 + baslangic_yili, Userform_Date.ScrollBar2, days)
End If
Unload Userform_Date
End Sub

Private Sub scrl_bar_Change()
    i = 0
    For i = 1 To 42
        Userform_Date.Controls("Label" & i) = ""
        Userform_Date.Controls("Label" & i).BackColor = RGB(255, 255, 204) 'vbCyan
        Userform_Date.Controls("Label" & i).MousePointer = fmMousePointerDefault
    Next
yil = Userform_Date.ScrollBar1 + baslangic_yili
ay = Userform_Date.ScrollBar2
Tarih = CDate("01." & ay & "." & yil)
gun = DateSerial(Year(Tarih), Month(Tarih) + 1, 0)

ilk = Application.Weekday(CDate(Tarih), 2)

For x = 1 To Format(gun, "dd")
Userform_Date.Controls("Label" & x + ilk - 1) = x
Next

    i = 0
    For i = 1 To 42
        If Userform_Date.Controls("Label" & i) = "" Then
        Userform_Date.Controls("Label" & i).BackColor = &H808080
        End If
    Next
    
If Year(Now) = Userform_Date.ScrollBar1 + baslangic_yili Then
    If Month(Now) = Userform_Date.ScrollBar2 Then
        For a = 1 To 42
            If Userform_Date.Controls("Label" & a) = CDbl(Day(Now)) Then
            Userform_Date.Controls("Label" & a).BackColor = &HFF&
            End If
        Next
    End If
End If

Userform_Date.TextBox1 = yil
Userform_Date.TextBox2 = VBA.Format(Tarih, "mmmm")
End Sub

Private Sub takvim_txt_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Set aktif_txt = takvim_txt
If takvim_txt = "" Then
Userform_Date.ScrollBar1 = Year(Now) - baslangic_yili
Userform_Date.ScrollBar2 = Month(Now)
Else
Userform_Date.ScrollBar1 = Year(CDate(takvim_txt)) - baslangic_yili
Userform_Date.ScrollBar2 = Month(CDate(takvim_txt))
End If
Userform_Date.Show
End Sub

To determine the coordinates (x,y) where the date userform will open, we need to find the position of the cursor. We used the Declare statement and GetCursorPos function to get the position of the cursor. GetCursorPos function needs a variable as a special data type to hold two integers (x value and y value). ⬇

#If VBA7 Then
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If
'We created custom variables that holds two integers
Private Type POINTAPI
   x As Long
   y As Long
End Type
'We dimension the variable that will hold the x and y cursor positions
Dim CurCoord As POINTAPI
Private Sub UserForm_Activate()
'We place the cursor positions into variable CurCoord
GetCursorPos CurCoord
'We determine the top (y value) and left (x value) coordinates where the userform will be displayed.
Me.Top = CurCoord.y * 0.75
Me.Left = CurCoord.x * 0.75
End Sub

✓ We filled the combobox on the userform with unique and sorted values. For this (to populate combobox unique sorted values), the following VBA codes have been added to the Userform_Initialize procedure : ⬇

'Unique Records
For x = 2 To Sheets("Sh-1").Cells(Rows.Count, 3).End(xlUp).Row
If WorksheetFunction.CountIf(Sheets("Sh-1").Range("C2:C" & x), Cells(x, 3)) = 1 Then
ComboBox1.AddItem Sheets("Sh-1").Cells(x, 3).Value
End If
Next

'Alphabetic Order
For a = 0 To ComboBox1.ListCount - 1
  For b = a To ComboBox1.ListCount - 1
        If ComboBox1.List(b) < ComboBox1.List(a) Then
c = ComboBox1.List(a)
    ComboBox1.List(a) = ComboBox1.List(b)
    ComboBox1.List(b) = c
       End If
  Next
Next

✓ After selecting first date, second date and product, clicking the Report button , the length of the userform increases and the filtered products are listed on the listbox. ⬇

Private Sub CommandButton1_Click()
  'Report Button
 Dim tarih1, tarih2 As Date, ara As Range, LastRow As Long
    Dim s1 As Worksheet
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set s1 = Worksheets("Sh-1")
    If TextBox1.Value = "" Or TextBox2.Value = "" Then
    MsgBox "You need to add the beginning and end dates", vbCritical, ""
    Exit Sub
    End If
    If ComboBox1.Value = "" Then
    MsgBox "Please choose a product from drop-down list", vbDefaultButton1, ""
    Exit Sub
    End If
    Call uzat
  'Calling userform stretch effect.
    tarih1 = VBA.Format(TextBox1.Value, "dd.mm.yyyy")
    tarih2 = VBA.Format(TextBox2.Value, "dd.mm.yyyy")
    ListBox1.Clear
    ListBox1.ColumnCount = 10
    ListBox1.ColumnWidths = "30;70;140;30;80;65;80;65;60;65"
    
    LastRow = s1.Range("B" & Rows.Count).End(xlUp).Row
    For Each ara In s1.Range("B2:B" & LastRow)
    If CLng(CDate(ara.Value)) >= CLng(CDate(tarih1)) And _
    CLng(CDate(ara.Value)) <= CLng(CDate(tarih2)) And _
    CStr(ara.Offset(0, 1).Value) = CStr(ComboBox1.Text) Then
ListBox1.AddItem
     ListBox1.List(ListBox1.ListCount - 1, 1) = VBA.Format(ara, "dd.mm.yyyy")
     ListBox1.List(ListBox1.ListCount - 1, 0) = ara.Offset(0, -1)
     ListBox1.List(ListBox1.ListCount - 1, 2) = ara.Offset(0, 1)
     ListBox1.List(ListBox1.ListCount - 1, 3) = ara.Offset(0, 2)
     ListBox1.List(ListBox1.ListCount - 1, 4) = ara.Offset(0, 3)
     ListBox1.List(ListBox1.ListCount - 1, 5) = VBA.Format(ara.Offset(0, 4), "#,##.00")
     ListBox1.List(ListBox1.ListCount - 1, 6) = ara.Offset(0, 5)
     ListBox1.List(ListBox1.ListCount - 1, 7) = VBA.Format(ara.Offset(0, 6), "#,##.00")
     ListBox1.List(ListBox1.ListCount - 1, 8) = ara.Offset(0, 7)
     ListBox1.List(ListBox1.ListCount - 1, 9) = ara.Offset(0, 8)
     End If
 Next ara
 Set s1 = Nothing
 Application.ScreenUpdating = True
 Application.EnableEvents = True
End Sub

✓ After the filtering event, the selected products with the listbox single select or multiple select, or all listbox items can be copied to “Sh-2” sheet. Two separate buttons have been added into userform for copying from listbox to worksheet :
1️⃣ “Copy All Items To Sh-2” button ,it’s codes : ⬇

Private Sub CommandButton5_Click()
Dim sat As Long, sut As Integer, s2 As Worksheet
Set s2 = Sheets("Sh-2")
s2.Cells.Clear
If ListBox1.ListCount = 0 Then
MsgBox "No data has been selected to copy.", vbExclamation, ""
Exit Sub
End If
sat = ListBox1.ListCount
sut = ListBox1.ColumnCount
s2.Range(s2.Cells(1, 1), s2.Cells(sat, sut)) = ListBox1.List
MsgBox "Data Were Copied.", vbInformation, ""
s2.Columns.AutoFit
Set s2 = Nothing
End Sub

2️⃣ “Copy Selected Items To Sh-2” button, it’s codes : ⬇

Private Sub CommandButton4_Click()
Dim Lstbx_item, Lstbx_rows, Lstbx_cols As Long
Dim bu As Boolean, Lstbx_loop, Lstbx_copy As Long, s2 As Worksheet
Set s2 = Sheets("Sh-2")
Lstbx_rows = ListBox1.ListCount - 1
Lstbx_cols = ListBox1.ColumnCount - 1
For Lstbx_item = 0 To Lstbx_rows
If ListBox1.Selected(Lstbx_item) = True Then
bu = True
Exit For
End If
Next
s2.Cells.Clear
If bu = True Then
With s2.Cells(1, 1)
For Lstbx_item = 0 To Lstbx_rows
If ListBox1.Selected(Lstbx_item) = True Then
Lstbx_copy = Lstbx_copy + 1
For Lstbx_loop = 0 To Lstbx_cols
.Cells(Lstbx_copy, Lstbx_loop + 1) = ListBox1.List(Lstbx_item, Lstbx_loop)
Next Lstbx_loop
End If
Next
End With
Else
MsgBox "No data has been selected to copy.", vbCritical, ""
Exit Sub
End If
MsgBox "The Selected Data Are Copied.", vbInformation, ""
s2.Select
s2.Columns.AutoFit
Set s2 = Nothing
End Sub