Excel – Filtering Data Excel Data from Survey to Obtain E-mails

emailmicrosoft excelmicrosoft-excel-2007microsoft-excel-2010

Over the summer we conducted a survey for a number of students to indicate their interest in a number of clubs. The way the responses were scanned in gave us a column for each club and a '1' in each cell in the column for each person (row) who indicated their interest for that particular club. The very first column is their e-mail address.

enter image description here

The end goal is to filter the data so that we can get the e-mails of those interested for each club – then send those e-mails off in an individual file to the clubs for their marketing.

Last year I did this by going through and 'filtering' each individual club for '1', copying all the e-mails from the e-mail column into a new document, saving it, and sending the file off to it's respective club.

Using the example above, we'd had a file for club1 that contained Email1, Email3, and Email7; another for Club 2 containing E-mail 5, etc etc. With 200+ clubs and 2000+ emails you can imagine this was time consuming.

A colleague suggested pivot tables might help, and we played around with it a bit to see if there was an easier solution…but we couldn't find one that dramatically cut down on the time it takes to go through the data.

Wondering if anyone had any ideas, or advice? Perhaps my solution was already the fastest?

Best Answer

You can use VBA to create individual files for each club. The procedure FilterData below creates a file for each club within the same directory as the file containing the VBA code, which also should contain the responses within a sheet called Responses.

Option Explicit

Sub FilterData()
    Dim Responses As Worksheet
    Dim Column As Long

    Set Responses = ThisWorkbook.Worksheets("Responses")
    Column = 2

    Do While Responses.Cells(1, Column).Value <> ""
        With Workbooks.Add(xlWBATWorksheet)
            With .Worksheets(1)
                Responses.Cells.Copy .Cells
                .Columns(Column).AutoFilter Field:=1, Criteria1:="<>1"
                .Rows(2).Resize(.Rows.Count - 1).Delete Shift:=xlUp
                .Columns(2).Resize(, .Columns.Count - 1).Delete Shift:=xlShiftToLeft
            End With

            .Close SaveChanges:=True, Filename:=ThisWorkbook.Path & "\" & Responses.Cells(1, Column).Value
        End With

        Column = Column + 1
    Loop
End Sub
Related Question