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

 

[warleque]

Thank-you Robert, with a little tweaking to represent my actual Workbook, this code worked perfectly... Sorry for the late response, just got around to updating this project

 

[warleque]

One follow up question. I have a few locations that don't have a regional director and so the field is blank, I'd like to skip them. Right now they are being collected and put into one separate spreadsheet saved currently as 2024.11.xlsx (I have a field named strMonthName that is linked to a single cell range where I type "Month" that I want added to the end of the file name...) I probably would have received an error otherwise?

 

[warleque]

I figured out an aswer to my own question.

1) I added a lable "SkipTo:" just above the Next varItem
2) Just above the If intArrayIndex >= 1 I added If varItem = "" Then GoTo SkipTo

Might be crude, but it works....

 

[Trebor76]

Hi warleque,

I'm glad we got it solved and thanks for the feedback.

Though you've got it working here's how I would exclude those entries where there's no regional director (if for nothing else for reference for anyone else looking through this thread):

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
        If Len(CStr(varItem)) > 0 Then
            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
        End If
    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

 

[warleque]

I changed my original if statement to root out blanks to this... in the rngcell area... if rngCell.offset(0, 4) = "" Then GoTo SkipTo. The GoTo SkipTo is just above the next rngCell

It worked better than my first attempt, but I like your solution better, no need for labels...