Lọc dữ liệu Excel theo giá trị cột và lưu cột vào tệp riêng lẻ

Nhiều năm trước, chúng tôi đã phải đưa ra một giải pháp để khảo sát kết quả mà chúng tôi đã nhận được thông qua CSV. Trước đó, chúng tôi sẽ nhận được dữ liệu trong đó cột đầu tiên là e-mail và các cột tiếp theo là 1 hoặc null để biểu thị sự quan tâm đến một tổ chức. Chúng tôi đã cố gắng đưa ra một giải pháp đi qua từng cột SAU cột e-mail và lưu vào sổ làm việc riêng một danh sách các email cho mỗi cột có 1 trong đó để chúng tôi có thể gửi cho các tổ chức đó.

Dữ liệu của chúng tôi (được đơn giản hóa) trông như thế này:

Trong đó kết quả cuối cùng sẽ cung cấp 4 tệp .xlsx mới (club1.xlsx, club2.xlsx, club3.xlsx, v.v.), mỗi tệp có 'email' có 1 hàng trong cột tương ứng. (Trong ví dụ trên Club1.xlsx sẽ có Email1, Email3, Email7 được liệt kê)

Vào thời điểm đó, cộng đồng StackExchange rất hữu ích trong việc giúp chúng tôi tìm ra giải pháp bằng cách cung cấp mã VBA sau để chạy 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

Nhưng bố cục của chúng tôi đã thay đổi và vì cuộc sống của chúng tôi, chúng tôi không thể tìm ra cách sửa đổi mã để bao gồm nhiều cột hơn trong lưu. Thay vì chỉ có cột 'Email', giờ đây chúng tôi có các cột bổ sung cho Tên ưa thích, Tên, Họ và Đại từ. Những nỗ lực của chúng tôi trong việc sửa đổi mã trên chỉ phục vụ để phá vỡ hoàn toàn macro hoặc chỉ lưu một hàng duy nhất.

Bất cứ ai cũng có và tư vấn về cách chúng tôi có thể viết mã mới hoặc sửa đổi mã hiện có để bao gồm tất cả các cột trong bản xuất của chúng tôi (vì vậy Club1.xlsx bây giờ sẽ có dữ liệu cột / hàng cho Tên được gọi, Tên, Họ, Đại từ và Email cho mỗi cột có "1").

Đây là bộ dữ liệu mới của chúng tôi:

Có suy nghĩ gì không? Tôi bối rối.

Không có dữ liệu nguồn để thử, đây sẽ là khách mời của tôi

Tôi đã tạo một quy trình cần nhắc cho tệp nguồn, sau đó tạo sổ làm việc đầu ra và thêm một trang tính cho mỗi câu lạc bộ liệt kê chi tiết bên quan tâm cho câu lạc bộ đó.

Nó giả định rằng tệp nguồn là một tệp excel có phần mở rộng "xlsx" Ngoài ra, nó giả định rằng dữ liệu nguồn nằm trên một trang tính có tên là "Phản hồi".

Nó đóng tệp nguồn nhưng không phải là sổ làm việc được tạo.

Tôi đã nhận xét mã để giải thích làm thế nào nó hoạt động.

   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

Hy vọng nó sẽ giúp, V.

Vào thời điểm đó, cộng đồng StackExchange rất hữu ích trong việc giúp chúng tôi tìm ra giải pháp bằng cách cung cấp mã VBA sau để chạy macro:

Điều này có phải được thực hiện trong một loại quy trình tự động? Nếu không, bạn chỉ có thể lọc toàn bộ bảng dựa trên các giá trị trong cột như club1, club2, club3 và sao chép kết quả vào các tệp riêng biệt. Nếu bạn chỉ có ít hơn 10 'câu lạc bộ' , điều này có thể nhanh hơn việc đấu tranh để viết VBA.