Фильтрация данных 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

Без исходных данных, это было бы мое предположение

Я создал процедуру, которая должна запросить исходный файл, затем создать выходную рабочую книгу и добавить лист для каждого клуба, в котором указаны сведения об этом клубе для заинтересованных сторон.

Предполагается, что исходный файл является файлом Excel с расширением "xlsx". Также предполагается, что исходные данные находятся на листе с именем "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

Надеюсь, это поможет, В.

Answer 2

В то время сообщество StackExchange было очень полезным, помогая нам найти решение, предоставив следующий код VBA для запуска макроса:

Это должно быть сделано в виде автоматизированного процесса? Если нет, вы можете просто отфильтровать всю таблицу на основе значений в столбце, таких как club1, club2, club3, и скопировать результат в отдельные файлы. Если у вас есть только менее 10 «клубов», это может быть быстрее, чем пытаться написать VBA.