Export Multiple Worksheets from a Workbook based on criteria

[warleque]

I am trying to figure out a way to automate the holding of the control key and clicking on worksheets and then saving them as a new sheet.

I have a setup 'tab' that contains the sheet names (one tab for each location) along with the regional director for that location. I'd like to be able to copy each location sheet for the specific regional director into a new separate workbook.

In example sheet in the picture contains 7 location sheets and 3 regional director names. Each file name for the new file created can be the name of the regional director. The screen shot is from the setup 'tab'

Any help would be appreciated...

 

[Trebor76]

Hi warleque,

Try this:

Option Explicit
Sub Macro1()

    'https://www.mrexcel.com/board/threads/export-multiple-worksheets-from-a-workbook-based-on-criteria.1267107

    Dim varItem As Variant, varItems As Variant
    Dim strArrSheets() As String
    Dim wsSrc As Worksheet
    Dim strSaveDir As String
    Dim lngLastRow As Long
    Dim intArrayIndex As Integer, intWBCount As Integer
    Dim rngCell As Range
   
    Application.ScreenUpdating = False
   
    Set wsSrc = ThisWorkbook.Sheets("SetUp")
    strSaveDir = "D:\Robert\MS_Office\Excel" 'This is the path where the workbooks will be saved. Change to suit.
    strSaveDir = IIf(Right(strSaveDir, 1) <> "\", strSaveDir & "\", strSaveDir) 'Ensure the path where the workbooks are to be saved to have a trailing backslash '\'
    lngLastRow = wsSrc.Cells(Rows.Count, "E").End(xlUp).Row   
    varItems = Evaluate("UNIQUE('" & wsSrc.Name & "'!E3:E" & lngLastRow & ")")

    For Each varItem In varItems
        For Each rngCell In wsSrc.Range("A3:A" & lngLastRow)
            If StrConv(rngCell.Offset(0, 4), vbLowerCase) = StrConv(varItem, vbLowerCase) Then
                intArrayIndex = intArrayIndex + 1
                ReDim Preserve strArrSheets(1 To intArrayIndex)
                strArrSheets(intArrayIndex) = rngCell
            End If
        Next rngCell
        If intArrayIndex >= 1 Then
            ThisWorkbook.Sheets(strArrSheets).Copy
            ActiveWorkbook.SaveAs strSaveDir & CStr(varItem) & ".xlsx", FileFormat:=51 'Workbook default
            ActiveWorkbook.Close SaveChanges:=False
            intWBCount = intWBCount + 1
        End If
        intArrayIndex = 0: Erase strArrSheets
    Next varItem
   
    Application.ScreenUpdating = False
   
    Select Case intWBCount
        Case 0
            MsgBox "There were no workbooks created." & vbNewLine & "Check the data layout and code and try again.", vbExclamation
        Case Else
            MsgBox "There were " & Format(intWBCount, "#,##0") & " workbooks created and saved in the..." & vbNewLine & strSaveDir & vbNewLine & "...folder ready for review.", vbInformation
    End Select

End Sub

Regards,

Robert