Без исходных данных, это было бы мое предположение
Я создал процедуру, которая должна запросить исходный файл, затем создать выходную рабочую книгу и добавить лист для каждого клуба, в котором указаны сведения об этом клубе для заинтересованных сторон.
Предполагается, что исходный файл является файлом 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 Надеюсь, это поможет, В.