Ohne Quelldaten zum Ausprobieren wäre dies meine Gastfamilie
Ich habe ein Verfahren erstellt, das zur Eingabe der Quelldatei auffordert, dann ein Ausgabe-Arbeitsbuch erstellt und für jeden Club ein Blatt hinzufügt, in dem die Details der betroffenen Parteien für diesen Club aufgeführt sind.
Es wird davon ausgegangen, dass es sich bei der Quelldatei um eine Excel-Datei mit der Erweiterung "xlsx" handelt. Außerdem wird davon ausgegangen, dass sich die Quelldaten auf einem Blatt mit der Bezeichnung "Antwort" befinden.
Es schließt die Quelldatei, aber nicht die generierte Arbeitsmappe.
Ich habe den Code kommentiert, um zu erklären, wie er funktioniert.
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 Hoffe, es hilft, V.