Link to home
Start Free TrialLog in
Avatar of marku24
marku24Flag for United States of America

asked on

Filtering Excel Data in VBA

I have an excel sheet with multiple columns, the first two columns: Name and Date, has a long list of names and dates in many rows.  I would like to run code that takes all unique dates for a particular name that i choose.  So if i select BOB, i would want all unique dates for Bob in ascending order to be listed on another excel tab.  Slight trick, the dates column has some non-date items listed under "BOB" that i do not want.  So i really need the code to do 2 things; filter Bob information in column 2 and filter for only what is a date.  Is that doable?
Avatar of Sam Jacobs
Sam Jacobs
Flag of United States of America image

Yes, it is, but it would be most helpful if you could provide a sample spreadsheet showing the first tab with the two columns (only a few rows), and how you would like the second tab to look.
You can do this with AutoFilter or AdvancedFilter.

You can get the basic code by using the Macro Recorder. Such code will need editing. You can post the code with help to do that.
Avatar of marku24

ASKER

sample file attached, notice I don't want the data of "Target" or "void"
Sorry ... don't see the file ...
Avatar of marku24

ASKER

my fault
sample.xlsx
Try adding the following into a module on your worksheet (file also attached).
This assumes that your worksheet only has 1 tab with the users and dates.
Let me know if not the case.
Option Explicit

Sub FindUserDates()
Dim lastRow As Integer
lastRow = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

Dim sht1idx As Integer
Dim sht1 As Worksheet
Dim sht2idx As Integer
Dim sht2 As Worksheet
Dim user As String

Set sht1 = ActiveSheet

user = InputBox("Who are you looking for?")
If user = "" Then End

For sht1idx = 2 To lastRow
    Debug.Print Cells(sht1idx, 1)
    If sht1.Cells(sht1idx, 1) = user And IsDate(sht1.Cells(sht1idx, 2)) Then
        If ActiveWorkbook.Sheets.Count = 1 Then
            Set sht2 = ActiveWorkbook.Sheets.Add(, ActiveSheet)
            sht2.Columns("B:B").NumberFormat = "m/d/yyyy"
            sht2.Name = user
            sht2idx = 1
        End If
        sht2.Cells(sht2idx, 1) = user
        sht2.Cells(sht2idx, 2) = sht1.Cells(sht1idx, 2)
        sht2idx = sht2idx + 1
    End If
Next

End Sub

Open in new window

SearchForUserDates.xlsm
Try this. Select any cell below the heading in column 'A'. Since you seemed to want sorting, I changed Nicholas' first date so that the sorting could be seen.
29136276.xlsm
Oops ... missed the sorting part ... I'm sure Martin's code will work just fine, but just to fill out my code, you could add the following before the End Sub (updated file also attached):
sht2.Activate
sht2.Sort.SortFields.Clear
sht2.Sort.SortFields.Add2 Key:=Range("B:B"), SortOn:=xlSortOnValues, _
                Order:=xlAscending, DataOption:=xlSortNormal
With sht2.Sort
    .SetRange Range("A:B")
    .Orientation = xlTopToBottom
    .Apply
End With

Open in new window

I have inserted a new sheet called "Filter" in the attached. You may rename it as per your need.

Right click on the Filter Tab --> View Code and place the codes given below into the opened code window and save your workbook as Macro-Enabled Workbook.

Private Sub Worksheet_Activate()
Dim wsdata As Worksheet
Dim x, dict
Dim i As Long

Set wsdata = Worksheets("Sheet1")
x = wsdata.Range("A1").CurrentRegion.Value
Set dict = CreateObject("Scripting.Dictionary")
On Error GoTo Skip
Application.EnableEvents = False
For i = 2 To UBound(x, 1)
    dict.Item(x(i, 1)) = ""
Next i

If dict.Count Then
    With Range("B1").Validation
        .Delete
        .Add xlValidateList, , , Formula1:=Join(dict.keys, ",")
    End With
Else
    Range("B1").Validation.Delete
End If
Skip:
Application.EnableEvents = True
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
Dim wsdata As Worksheet
Dim x, dict
Dim i As Long

Set wsdata = Worksheets("Sheet1")
x = wsdata.Range("A1").CurrentRegion.Value
Set dict = CreateObject("Scripting.Dictionary")
On Error GoTo Skip
If Target.Address(0, 0) = "B1" Then
    Application.EnableEvents = False
    Range("A3").CurrentRegion.Offset(1).Clear
    If Target <> "" Then
        For i = 2 To UBound(x, 1)
            If x(i, 1) = Target And IsDate(x(i, 2)) Then
                dict.Item(x(i, 2)) = ""
            End If
        Next i
        If dict.Count Then
            Range("B4").Resize(dict.Count) = Application.Transpose(dict.keys)
            Range("A4").Resize(dict.Count) = Target
            Range("A3").CurrentRegion.Sort key1:=Range("B4"), order1:=xlAscending, Header:=xlYes
        End If
        Range("A3").CurrentRegion.Borders.Color = vbBlack
    End If
End If

Skip:
Application.EnableEvents = True
End Sub

Open in new window

In the attached, on Filter Sheet, if you select a Name from the drop down list in Cell B1, the relevant data would be populated below.
The drop down list in Cell B1 is being created by the macro dynamically so that if you add/delete the names in column A on Sheet1, the drop down list in B1 would be updated accordingly.
FilterData.xlsm
Avatar of marku24

ASKER

Thank you all.  I am a little new to coding VBA in Excel.  I used Martin's solution and modified it to work in my workbook.  Works very well.  My one issue is that I am not calling the routine by selecting a cell on that same page (although pretty cool), i am calling it from another tab unrelated to where the data resides.  My data is on a tab call Data Collection, I am calling it from a tab called Setup Evaluations.  I tried to take the code and put in a module as a function.  It seems to not like me calling the function and says Object Required.  Is this because i do not have a value for:  (ByVal Target As Range).  I changed the name of the function to PeopleDateSort and tried calling it by: Call PeopleDateSort

Do i need to seed it with a target parameter?
Please show me what the Setup Evaluations sheet looks like.
Avatar of marku24

ASKER

It's just a menu page that has a command button to run the script.  No important data or code.  The data is on the data collection tab and it writes to a tab i renamed "workpapers".  All of that works fine when i use your code from the data collection tab.  I just want to trigger it from a menu page.  I can change the value of the target value by having it reference a cell on a sheet.  That works ok too.  It's just calling the function in a module that is giving me a problem.  Does that make sense?
Are you free to attach your actual workbook?
Also if the Setup Evaluations sheet has "No important data or code" I assume it doesn't have the employee names. If so how do you want to determine which employee to look at?
Avatar of marku24

ASKER

good point.  sorry i am dragging this on.  I use a list box on the Setup Evaluations tab that write the person's name to cell D5.  I use this and it works fine:  Target = Sheets("Setup Evaluations").Range("D5").  So this would give me the value of "Nicholas" or "Bob", etc.  I just can't call the code that i put in a module from the Setup Evaluations tab.

I would attach workbook but it has employee information.
See if this works for you. I made it so that the Setup Evaluations sheet will always contain a dynamic list of the unique names on the Data Collection sheet. In other words changes to the names on the Data Collection sheet will be reflected in the Setup Evaluations sheet. Click any one of the names in the Setup Evaluations sheet to see the results for that employee.
29136276a.xlsm
I edited my comment in the above.
Avatar of marku24

ASKER

Is there a way to have it reference the cell : Sheets("Setup Evaluations").Range("D5")?  I have other unrelated information on the screen and every time I click on the screen the code triggers.  I would like to tell the code when to execute, preferably with a command button.  Apart from that the code works perfectly.  Exactly what I wanted.  
thank you for all your help
ASKER CERTIFIED SOLUTION
Avatar of Martin Liss
Martin Liss
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of marku24

ASKER

Amazing.  Thank you so much.
You’re welcome and I’m glad I was able to help.

If you expand the “Full Biography” section of my profile you’ll find links to some articles I’ve written that may interest you.

Marty - Microsoft MVP 2009 to 2017
              Experts Exchange Most Valuable Expert (MVE) 2015, 2017
              Experts Exchange Top Expert Visual Basic Classic 2012 to 2018
              Experts Exchange Top Expert VBA 2018