Creating mutiple workbooks from multiple worksheets

[JackTripper]

Hi Excel Gurus, I have what I think is a simple problem requiring a simple VBA solution. I have huge workbook that has over 60 worksheets. The first 3 worksheets belong to Finance and the names all start with "Fin_xxx","Fin_yyy",etc. The next 7 sheets belong to HR and are prefixed by "HR_xxx", "HR_yyy", and so on. All I want to do is write a code that loops through the workbook and combines all worksheets that start with "Fin_" into one workbook for Finance, and those that start with "HR_" into a separate workbook for HR, and so on. Help???????

 

[mohan.pandey87]

Try this:

Sub LM_Test()


    Dim wksSht                  As Worksheet
    Dim wbkTemp                 As Workbook
    Dim vararrShtType()         As Variant
    Dim vararrSht()             As Variant
    Dim lngLoop                 As Long
    Dim lngLoop1                As Long
    Dim lngCount                As Long
    
    'Populating sheet types in an array
    vararrShtType = Array("Fin_", "Hr_")
    
    'Redimenson array
    ReDim vararrSht(1 To UBound(vararrShtType) + 1, 1 To ThisWorkbook.Worksheets.Count)
    
    'Looping through each sheet
    lngCount = 0
    For Each wksSht In ThisWorkbook.Worksheets
        For lngLoop = LBound(vararrShtType) To UBound(vararrShtType)
            If Left(LCase(wksSht.Name), Len(vararrShtType(lngLoop))) = LCase(vararrShtType(lngLoop)) Then
                lngCount = lngCount + 1
                vararrSht(lngLoop + 1, lngCount) = wksSht.Name
            End If
        Next lngLoop
    Next wksSht
    
    'Looping for sheets to combined it in a single workbook
    For lngLoop = LBound(vararrSht) To UBound(vararrSht)
        Set wbkTemp = Nothing
        For lngLoop1 = LBound(vararrSht) To UBound(vararrSht, 2)
            If LenB(Trim(vararrSht(lngLoop, lngLoop1))) > 0 Then
                'Adding new workbook
                If wbkTemp Is Nothing Then
                    Set wbkTemp = Workbooks.Add(1)
                End If
                'Copying sheets to new workbook
                ThisWorkbook.Worksheets(vararrSht(lngLoop, lngLoop1)).Copy After:=wbkTemp.Sheets(wbkTemp.Sheets.Count)
            End If
        Next lngLoop1
        If Not wbkTemp Is Nothing Then
            'Saving workbook
            wbkTemp.SaveAs ThisWorkbook.Path & Application.PathSeparator & vararrShtType(lngLoop - 1) & ".xlsx", 51
        End If
        'Closing workbook
        If Not wbkTemp Is Nothing Then wbkTemp.Close 1
        Set wbkTemp = Nothing
    Next lngLoop
    
    'Releasing memory
    Set wksSht = Nothing
    Set wbkTemp = Nothing
    Erase vararrShtType
    Erase vararrSht
    lngLoop = Empty
    lngLoop1 = Empty
    lngCount = Empty


End Sub

 

[JackTripper]

Mohan.Pandey87, your code works perfectly. You are a star!!!