Filtering Excel Data by Column Value and Saving Columns to Individual Files

Question

Many years back we had to come up with a solution to survey results that we were getting via CSV. Back then we'd get data where the first column was e-mails, and subsequent columns were 1's or null to indicate interest in an organization. We were trying to come up with a solution that went through each column AFTER the e-mail column, and save out in separate workbooks a list of emails for each column that had a 1 in them so we could send it to those organizations.

Our data (simplified) looked like this:

Where the end result would provide 4 new .xlsx files (club1.xlsx, club2.xlsx, club3.xlsx,etc), each with the 'emails' that had 1's in their row for their respective column. (In the above example Club1.xlsx would have Email1, Email3, Email7 listed)

At the time, the StackExchange community was super helpful in helping us source a solution by providing the following VBA code to run a macro:

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

But our layout has since changed and for the life of us we can't figure out how to modify the code to include more columns in the save out. Instead of just having the 'Email' column, we now have additional columns for Preferred Name, First Name, Last Name, and Pronouns. Our attempts at modifying the above code has only served to either break the macro entirely, or only save out a single row.

Would anyone have and advice on to how we could either write new code, or modify the existing code to include all the columns in our exports (so Club1.xlsx would now have columns/row data for referred Name, First Name, Last Name, Pronouns, and Emails for each column with a "1").

Here's our new data set:

Any thoughts? I'm stumped.

Answer 1

Without source data to try with, this would be my guestimate

I have created a procedure that should prompt for the source file, then create an output workbook and add a sheet for each club listing the interested party details for that club.

It assumes that the source file is an excel file with the extension "xlsx" Also it assume that the source data is on a sheet called "Response".

It closes the source file but not the generated workbook.

I have commented the code to explain how it works.

   Sub FilterData()

    '------------- Define the Variables -----------------
    'Define workbooks and worksheets
    Dim wbkSource As Workbook, shtSource As Worksheet '. Source Date
    Dim wbkList As Workbook, shtList As Worksheet '..... Final workbook with separate sheets

    'Define Index looping variables  and last positions
    Dim idxRows As Double, idxCols As Double
    Dim lastRow As Double, lastCol As Double

    'Define the identifier holders
    Dim fileName As String '................... Holds the selected source file name
    Dim clubName As String '................... Holds the current Club name
    Dim cntRows As Double '.................... Flags is there is a club entry or not and tracks the club entry position

    '----------------- Assign the startup values
    'Open the source file  and assign it as  wbkSource, when the user has not cancelled
    fileName = Application.GetOpenFilename("Excel File (*.xlsx),*.xlsx, All Files (*.*), (*.*)", , "Please select the source file")
    If fileName <> "False" Then

            'Assign the workbook source to the opened file
            Set wbkSource = Workbooks.Open(fileName)

            'Assign the source worksheet
            Set shtSource = wbkSource.Worksheets("Responses")

            'Create the output workbook and assign it to the wbkList
            Workbooks.Add
            Set wbkList = Workbooks(Workbooks.Count)

            'Define the last row and column positions
            lastRow = shtSource.Cells.SpecialCells(xlCellTypeLastCell).Row
            lastCol = shtSource.Cells.SpecialCells(xlCellTypeLastCell).Column

            '-------------------------------------- Loop through each possible club
            For idxCols = 6 To lastCol
                'Get the next club name and reset the flag
                clubName = shtSource.Cells(1, idxCols)
                cntRows = 0

                '----------------------------------- Loop for each row
                For idxRows = 2 To lastRow

                    'When we have an interest for this contact for this club
                    If shtSource.Cells(idxRows, idxCols) = 1 Then
                        'Increment the row count
                        cntRows = cntRows + 1

                            'If this is the first time create the worksheet for this club
                            If cntRows = 1 Then
                                wbkList.Worksheets.Add
                                Set shtList = wbkList.Worksheets.Add
                                shtList.Name = clubName

                                'Create the Title row
                                shtList.Cells(1, 1) = "Preferred"
                                shtList.Cells(1, 2) = "First"
                                shtList.Cells(1, 3) = "Last"
                                shtList.Cells(1, 4) = "Pronouns"
                                shtList.Cells(1, 5) = "Emails"

                                'Increment the row count to allow for the title
                                cntRows = cntRows + 1

                            End If

                            'Add the data to the club sheet
                            shtList.Cells(cntRows, 1) = shtSource.Cells(idxRows, 1)
                            shtList.Cells(cntRows, 2) = shtSource.Cells(idxRows, 2)
                            shtList.Cells(cntRows, 3) = shtSource.Cells(idxRows, 3)
                            shtList.Cells(cntRows, 4) = shtSource.Cells(idxRows, 4)
                            shtList.Cells(cntRows, 5) = shtSource.Cells(idxRows, 5)


                    End If 'Interested for this club

                Next idxRows
                '----------------------------------- each row

            Next idxCols
            '------------------------------------ Each Club

            'Turn off warning termporarily and close the source file
            Application.DisplayAlerts = False
            wbkSource.Close
            Application.DisplayAlerts = True


    Else
        'Notify the user of the cancelling of the macro
        MsgBox "Error: Canncelled by user, closing marco.", vbCritical, "User cancelled!"
    End If


    End Sub

Hope it helps, V.

Answer 2

At the time, the StackExchange community was super helpful in helping us source a solution by providing the following VBA code to run a macro:

Does this have to be done in a kind of automated process? If not, you can just filter the entire table based on the values in column like club1, club2, club3, and copy the result to separate files. If you only have less than 10 'clubs', this might be faster than struggling to write VBA.