按列值过滤 Excel 数据并将列保存到单个文件

Question

很多年前，我们必须想出一个解决方案来处理通过 CSV 获得的调查结果。当时，我们得到的数据第一列是电子邮件，后面的列是 1 或空值，以表示对某个组织感兴趣。我们试图想出一个解决方案，在电子邮件列之后遍历每一列，并在单独的工作簿中保存每列包含 1 的电子邮件列表，以便我们可以将其发送给这些组织。

我们的数据（简化）如下：

最终结果将提供 4 个新的 .xlsx 文件（club1.xlsx、club2.xlsx、club3.xlsx 等），每个文件都包含“电子邮件”，其行中相应的列包含 1。（在上面的示例中，Club1.xlsx 将列出 Email1、Email3、Email7）

当时，StackExchange 社区非常乐于助人，通过提供以下 VBA 代码来运行宏，帮助我们找到解决方案：

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

但此后我们的布局发生了变化，我们无论如何也想不出如何修改代码以在保存中包含更多列。现在，我们不仅拥有“电子邮件”列，还拥有“首选名称”、“名字”、“姓氏”和“代词”等附加列。我们尝试修改上述代码，但结果要么完全破坏了宏，要么只保存了一行。

是否有人能建议我们如何编写新代码或修改现有代码以包含我们导出中的所有列（因此 Club1.xlsx 现在将具有列/行数据，包括所指名称、名字、姓氏、代词和电子邮件，每列都有“1”）。

这是我们的新数据集：

有什么想法吗？我被难住了。

Answer 1

如果没有源数据可供尝试，这将是我的估计

我已经创建了一个程序，该程序应提示源文件，然后创建一个输出工作簿并为每个俱乐部添加一张表，列出该俱乐部的相关方详细信息。

它假定源文件是扩展名为“xlsx”的 Excel 文件，并且假定源数据位于名为“Response”的工作表上。

它关闭源文件但不关闭生成的工作簿。

我已经注释了代码来解释它是如何工作的。

   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

希望它有帮助，V。

Answer 2

当时，StackExchange 社区非常乐于助人，通过提供以下 VBA 代码来运行宏，帮助我们找到解决方案：

这必须通过某种自动化过程来完成吗？如果没有，您可以根据列中的值过滤整个表，例如俱乐部1、俱乐部2、俱乐部3，并将结果复制到单独的文件中。如果你只有少于 10‘俱乐部’，这可能比费力地编写 VBA 要快得多。