Filtrando dados do Excel por valor de coluna e salvando colunas em arquivos individuais

Question

Muitos anos atrás, precisávamos encontrar uma solução para pesquisar os resultados que estávamos recebendo por meio do CSV. Naquela época, recebíamos dados em que a primeira coluna era e-mails, e colunas subseqüentes eram 1s ou null para indicar interesse em uma organização. Estávamos tentando encontrar uma solução que passasse por cada coluna APÓS a coluna de e-mail e salvássemos em pastas de trabalho separadas uma lista de e-mails para cada coluna que tivesse um 1 para que pudéssemos enviá-la para essas organizações. / p>

Nossos dados (simplificados) ficaram assim:

Ondeoresultadofinalforneceria4novosarquivos.xlsx(club1.xlsx,club2.xlsx,club3.xlsx,etc),cadaumcomos'emails'quetinham1snalinhaparaarespectivacoluna.(Noexemploacima,oClub1.xlsxteriaEmail1,E-mail3,E-mail7listado)

Nomomento,acomunidadedoStackExchangefoimuitoútilparanosajudaraobterumasoluçãofornecendooseguintecódigodoVBAparaexecutarumamacro:

OptionExplicitSubFilterData()DimResponsesAsWorksheetDimColumnAsLongSetResponses=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

Mas nosso layout mudou desde então e, para a vida de nós, não conseguimos descobrir como modificar o código para incluir mais colunas no salvamento. Em vez de apenas ter a coluna "E-mail", agora temos colunas adicionais para Nome, Nome, Sobrenome e Pronomes preferidos. Nossas tentativas de modificar o código acima serviram apenas para quebrar a macro totalmente ou apenas salvar uma única linha.

Alguém poderia ter algum conselho sobre como poderíamos escrever um novo código ou modificar o código existente para incluir todas as colunas em nossas exportações (assim, o Club1.xlsx agora teria dados de colunas / linhas para o Nome, o Primeiro Nome, Sobrenome, pronomes e e-mails para cada coluna com um "1".

Este é o nosso novo conjunto de dados:

Alguma ideia? Estou perplexo.

    

Answer 1

Sem dados de origem para experimentar, este seria meu convidado

Eu criei um procedimento que deve solicitar o arquivo de origem, criar uma pasta de trabalho de saída e adicionar uma folha para cada clube listando os detalhes da parte interessada para esse clube.

Ele assume que o arquivo de origem é um arquivo excel com a extensão "xlsx" Também assume que os dados de origem estão em uma planilha chamada "Resposta".

Fecha o arquivo de origem, mas não a pasta de trabalho gerada.

Comentei o código para explicar como funciona.

   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

Espero que ajude, 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:

Isso tem que ser feito em uma espécie de processo automatizado? Se não, você pode filtrar a tabela inteira com base nos valores da coluna como club1, club2, club3 e copie o resultado para separar os arquivos. Se você tiver menos de 10 'clubes' , isso pode ser mais rápido do que tentar escrever VBA.