PLEASE help me with a VBA macro to filter data with mutiple criteria

[dlpessleo]

I am learning about VBA and Macros and am currently struggling with a small project. I am sure that it is a simple solution but after days of struggling, I have decided to ask for help. I have a small spreadsheet with 3 Worksheets (Interface, Data & Lists) I have named the ranges on the Lists sheet and linked the sheets and even managed to write some VBA Code to get the Filter Data and Clear buttons to work.


What I have been trying to achieve is this:


If you look at the Interface worksheet - I would like to be able to enter the Start Date (C6), Finish Date (D6), Customer (E6), Invoice Number (F6) and Product Name (G6) in the respective cells and then click on the "Filter Data" button so that a VBA Macro can automatically filter the date into the range C8:I8 below.


The date filter and invoice number filter seems to be working with the "Filterme" macro, but not the Product Name or Customer filters. I think it might have something to do with the coding of the "Filterme" macro or something else I might have missed. I have been pulling my hair out trying to find the problem and after days of struggling I have decided to ask for help.


I cannot move forward with this project until I get the filters sorted. Any help would be greatly appreciated...

[westconn1]

if you want to input the criteria into row 6, why are you filtering on range M5:Q6?
do you have to enter the data twice?
suggest some valid values to filter on that would provide realistic results

[p45cal]

try replacing your filterme macro with:

Sub Filterme()
Dim xx As Range  ' Macro4 Macro
Set OrigSelection = Selection
On Error Resume Next
Set xx = Range("C6:G6").SpecialCells(xlCellTypeConstants, 3)
On Error GoTo 0
If Not xx Is Nothing Then
  colmCount = xx.Cells.Count
  Set xx = Union(xx, xx.Offset(-1))
  Range("M5:Q6").ClearContents
  xx.Copy
  Range("M5").PasteSpecial Paste:=xlPasteValues
  OrigSelection.Select
  For Each cll In Range("M5").Resize(, colmCount)
    If InStr(1, cll.Value, "date", vbTextCompare) > 0 Then
      If InStr(1, cll.Value, "start", vbTextCompare) > 0 Then a = ">=" Else a = "<="
      cll.Value = "Date"
      cll.Offset(1).Value = a & CLng(cll.Offset(1).Value)
    End If
  Next cll
  Set CritRng = Range("M5").Resize(2, colmCount)
  Sheet2.Range("D4").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=CritRng, CopyToRange:=Sheet1.Range("C8:I8"), Unique:=False
Else
  MsgBox "no filter criteria"
End If
End Sub

ps. if this is an assignment/homework your tutor (Trevor?) will probably suspect this is not your own work!

[Paul_Hossler]

If you don't really want a filter, a simple loop would be easier I think

Option Explicit
Sub Clearme()
'
' Clearme Macro
' Clear all filtered data
'
' Keyboard Shortcut: Ctrl+Shift+C
'
    Worksheets("Interface").Range("C9:I40").ClearContents
    
End Sub
Sub Filterme()
    
    Dim wsData As Worksheet, wsInterface As Worksheet
    
    Dim dtStart As Date, dtEnd As Date
    Dim sCustomer As String, sProduct As String
    Dim iInvoice As Long
    Dim iOut As Long, iDataRow As Long
    
    Set wsData = Worksheets("Data")
    Set wsInterface = Worksheets("Interface")
    
    Application.ScreenUpdating = False
    
    With wsInterface
        .Range("C9:I40").ClearContents
        dtStart = .Range("C6").Value
        dtEnd = .Range("D6").Value
        sCustomer = LCase(.Range("E6").Value)
        iInvoice = .Range("F6").Value
        sProduct = LCase(.Range("G6").Value)
    End With

    If CLng(dtStart) = 0 Then dtStart = DateSerial(2000, 1, 1)
    If CLng(dtEnd) = 0 Then dtEnd = DateSerial(2099, 12, 31)

    iOut = 9
    iDataRow = 5
    
    With wsData
        'Date    Invoice Number  Customer    Unit price  Product Name    Quantity    Total
        Do While Len(.Cells(iDataRow, 4).Value) > 0
            If .Cells(iDataRow, 4).Value < dtStart Then GoTo NextDataRow
            If .Cells(iDataRow, 4).Value > dtEnd Then GoTo NextDataRow
            If iInvoice > 0 Then
                If .Cells(iDataRow, 5).Value <> iInvoice Then GoTo NextDataRow
            End If
            If Len(sCustomer) > 0 Then
                If LCase(.Cells(iDataRow, 6).Value) <> sCustomer Then GoTo NextDataRow
            End If
            If Len(sProduct) > 0 Then
                If LCase(.Cells(iDataRow, 8).Value) <> sProduct Then GoTo NextDataRow
            End If
                        
            Call .Cells(iDataRow, 4).Resize(1, 7).Copy(wsInterface.Cells(iOut, 3))
                        
            iOut = iOut + 1
            
NextDataRow:
            iDataRow = iDataRow + 1
        
        Loop
    End With
     
    Application.ScreenUpdating = True
     
    MsgBox "Done"
     
     
End Sub

Attached is my update if you're interested

You should add error checking, e.g. is Start really a date, etc.

[snb]

You could consider to use advancedfilter.

[dlpessleo]

Thank you for your help.

[dlpessleo]

Thank you so very much for your quick response and great feedback I have used your suggestion and adapted it to suit the particular project that I am working on and it all seems to be working great except for the Product filter again...

Please could you just have a look at my adapted code to check what I have done wrong? The Product filter is just not filtering correctly. I think I might have made a boo-boo with typing the code.

PS: My Customer and Product drop down boxes were linked to other worksheets that were not included in this workbook, so they will not show...