VBA Loop through dropdown list, copy data based on criteria, and save to new workbook.

[Legacy 316613]

Hi Excel VBA experts,

Very new to VBA but loving the challenge but 2 hours later and still cannot get a solution to my problem.

So here it is. I have data in a sheet aptly named "MasterData"

I have a drop downlist in a sheet called "Macros" in cell B4. The range in B4 is populated by a dynamic range in Column Q of the "MasterData" sheet.
Managed to keep the range dynamic using lastrow in the range i.e. "Q2:Q & lastrow"

I need to run a loop which dynamically works down this dropdown list and filters the data based on criteria in Column 10 of the "MasterData" sheet.

Then I need to copy the filtered data / visible data to a new workbook and save the workbook with the name in the cell B4.

Close the workbook and repeat the loop until finished.

Promised my boss I would have this completed by next Monday and looking for some support here, else it is going to be a very long weekend

Please help.

 

[rondeondo]

Hi there
I've written something that does kinda what you're after. I am a little slack and require the user make the list of filter options, then in the macro the user is asked for sheet to filter, column to filter, list of values, and prefix/suffixs, also how many columns to leave off. So when I use it I add a column to the right side of the data to be the filter and set this to 1 to drop the last column. I also have output format options of CVS, XLSX and TXT. The TXT option writes out to a text file, this may not be useful so drop it, I do this so I can build a CSV with | character delimiters.... I'll paste it in here and you can take it and make changes you need for your purposes:

Sub SplitFile()
Dim supplierListSheetName As String
Dim dataListSheetName As String
Dim supplierList As Worksheet
Dim dataList As Worksheet
Dim outputFileName As String
Dim outputFilePath As String
Dim outputFileSuffix As String
Dim outputFileType As String
Dim currentFile As Workbook
Dim newFile As Workbook
Dim newSheet As Worksheet
Dim filterColumn As Integer ' column in data that contains the selection criteria, ie. supplier name
Dim fileCount As Integer
Dim columnsToExclude As Integer

On Error GoTo SplitFile_Err
'future improvements, make the following user selection on execution
'supplierListSheetName = "SupplierList"
dataListSheetName = SelectWorkSheetName("Please Select the Sheet with the Data to Split", "Data List")
If dataListSheetName = "" Then
    Exit Sub
End If

filterColumn = SelectAddress("Select the Column to be filtered", "Filter Column", "Column") ' column in data that contains the selection criteria, ie. supplier name
If filterColumn < 1 Then
    Exit Sub
End If

supplierListSheetName = SelectWorkSheetName("Please Select the Sheet with the list to filter by, Will use first column", "Filter List")
If supplierListSheetName = "" Then
    Exit Sub
End If

columnsToExclude = InputBox("Select how many columns to exclude from the right hand end of the data", "Excluded Column Count", 0)

outputFileName = InputBox("Default output File prefix", "Prefix", "EGO_")
If outputFileName = "" Then
    Exit Sub
End If

outputFileSuffix = InputBox("Default output File Suffix, before file extension", "Sufix", "_HPV.CC")
If outputFileSuffix = "" Then
    Exit Sub
End If

outputFileType = InputBox("Default output File Suffix, CSV or XLSX or TXT", "Sufix", "CSV|XLSX|TXT")
If outputFileType = "" Or outputFileType = "CSV|XLSX|TXT" Then
    Exit Sub
End If

outputFilePath = InputBox("Output file Location", "Location", "H:\Shared\Operational\DataSystems\SCIT\CommonCatalogue\PROD\01-Processed\tmp")
If outputFilePath = "" Then
    Exit Sub
End If

If Right(outputFilePath, 1) <> "\" Then
    outputFilePath = outputFilePath & "\"
End If

Set currentFile = ThisWorkbook


For Each ws In ActiveWorkbook.Sheets
    If ws.Name = supplierListSheetName Then  'sheet with list of suppliers
        Set supplierList = ws
    End If
    If ws.Name = dataListSheetName Then
       Set dataList = ws
    End If
Next ws

If supplierList Is Nothing Then
    MsgBox "Supplier list not found, looking for sheet name: " & supplierListSheetName
    Exit Sub
End If

If dataList Is Nothing Then
    MsgBox "Data Sheet not found, looking for sheet name: " & dataListSheetName
    Exit Sub
End If
fileCount = 0
    For Each supplierNameCell In supplierList.Range(supplierList.Cells(1, 1), supplierList.Cells(supplierList.Cells.SpecialCells(xlLastCell).Row, 1))
        If Len(supplierNameCell.Value) > 0 Then
            supplierName = supplierNameCell.Value
     
                'apply filter to data sheet
                'copy contents to new file with supplier name in file name
                dataList.AutoFilterMode = False
    '            dataList.ListObjects("Table13").Range.AutoFilter Field:=1, Criteria1:=supplierName
                dataList.Range("A1", dataList.Cells.SpecialCells(xlLastCell)).AutoFilter Field:=filterColumn, Criteria1:=supplierName
                'select all
                dataList.Range("A1", dataList.Cells(dataList.Cells.SpecialCells(xlLastCell).Row, dataList.Cells.SpecialCells(xlLastCell).Column - columnsToExclude)).Copy
                
            If outputFileType <> "TXT" Then
                Set newFile = Workbooks.Add
                
                With newFile
                    Set newSheet = .Sheets(1)
    
                    'create new file
                    newSheet.Range("A1").PasteSpecial xlPasteColumnWidths, xlPasteSpecialOperationNone, False, False
                    newSheet.Range("A1").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
                    newSheet.Range("A1").PasteSpecial xlPasteFormats, xlPasteSpecialOperationNone, False, False
                    newSheet.Range("A1", newSheet.Cells.SpecialCells(xlLastCell)).EntireColumn.AutoFit
                    Application.DisplayAlerts = False
                    If outputFileType = "CSV" Then
                        .SaveAs fileName:=outputFilePath & outputFileName & Replace(Replace(supplierName, "/", ""), "|", " - ") & outputFileSuffix & ".csv", FileFormat:=xlCSV, ConflictResolution:=xlLocalSessionChanges, Local:=True
                    Else
                       .SaveAs fileName:=outputFilePath & outputFileName & Replace(Replace(supplierName, "/", ""), "|", " - ") & outputFileSuffix & ".xlsx", ConflictResolution:=xlLocalSessionChanges
                    End If
                    
                    Application.DisplayAlerts = True
                    newFile.Close False
                End With
            End If
            
                If outputFileType = "TXT" Then
                    Application.Wait (Now + TimeValue("0:00:01"))
                    Call copyToNotepad(outputFilePath & outputFileName & Replace(Replace(supplierName, "/", ""), "|", " - ") & outputFileSuffix & ".txt")
                End If
            fileCount = fileCount + 1
       End If
    Next supplierNameCell
dataList.ShowAllData
MsgBox "File Split complete, " & fileCount & " files created"
Exit Sub

SplitFile_Err:
MsgBox "Error occured" & vbCr & Err.Number & vbCr & Err.Description & vbCr & outputFilePath & outputFileName & Replace(Replace(supplierName, "/", ""), "|", " - ") & ".xlsx", vbCritical + vbOKOnly
End Sub