PDA

View Full Version : PLEASE help me with a VBA macro to filter data with mutiple criteria



dlpessleo
08-23-2014, 04:47 PM
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:banghead:, 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
08-24-2014, 05:01 AM
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
08-24-2014, 07:05 AM
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
08-24-2014, 07:36 AM
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
08-24-2014, 02:16 PM
You could consider to use advancedfilter.

dlpessleo
08-24-2014, 03:00 PM
Thank you for your help. :content:

dlpessleo
08-24-2014, 07:08 PM
Thank you so very much for your quick response and great feedback:clap: 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. :dunno

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...