Add-in to saving groups of worksheets as a single workbook

Hi all

I have another little conumdrum I'm trying to work out.

I'm using one of Ron's scripts as an add-in which I've just amended the output path for.

http://www.rondebruin.nl/tips.htm

This script essentially creates a new workbook from each worksheet in the active workbook.

As I have a workbook of about 500 worksheets, I am trying to group the worksheets opposed to having to split all and rejoin them manually.

Luckily all of my worksheets names are initials with numbers after them (as assigned by excel when merged):

e.g., RH, RH (2), RH (3), RH (4), AG, AG (2), AG (3) and so on.

That said there are some random ones too, but I'm happy for them to be kicked out as individual files.

Anyway I'm pretty sure there is a way this can be added into this existing script by addressing Sheet.Name perhaps but I'm a bit unsure exactly..

Sorted in order (i.e. 2,3,4) would also be a bonus but not essential as they need to manually checked and I have a separate macro for sorting worksheets anyway.

Any input would be much appreciated!!

Cheers

Danny

Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ActiveWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "(dd-mm-yy)")
    FolderName = "F:\General Docs\Output" & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy

            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook

            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        Select Case Sourcewb.FileFormat
                        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                        Case 52:
                            If .HasVBProject Then
                                FileExtStr = ".xlsm": FileFormatNum = 52
                            Else
                                FileExtStr = ".xlsx": FileFormatNum = 51
                            End If
                        Case 56: FileExtStr = ".xls": FileFormatNum = 56
                        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                        End Select
                    End If
                End If
            End With

            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If


            'Save the new workbook and close it
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "You can find the files in " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Do you have a list of initials stored in the workbook?

No, unfortunately not. I'd have to use Sourcewb.Sheets.Name in this instance as there is no common cells across all sheets.

I thought about using Case but the script would get too bulky.

I think you need a list of initials, maybe created with the code then loop through the list to create the workbook.

Yeah the initials could be created in the code. i'll try that first. cheers!

Not completely tested but try this

Option Explicit
Dim sh         As Worksheet
Dim tempSht    As Worksheet
Dim shName     As String
Dim rng        As Range

Sub create_list_sheets()
    Dim R      As Long
    Dim x
    R = 1
    Worksheets.Add
    Set tempSht = ActiveSheet
    With tempSht
        For Each sh In ThisWorkbook.Worksheets
            If sh.Visible = -1 Then shName = Left(sh.Name, 2)
            Set rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
            If Application.WorksheetFunction.CountIf(rng, shName) < 1 Then
                .Cells(R, 1) = shName
                R = R + 1
            End If
        Next sh
    End With
End Sub

Sub main()
    Dim cl     As Range
    With tempSht
        Set rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
        For Each cl In rng
            shName = cl.Value
            Call Copy_Every_Sheet_To_New_Workbook
        Next cl
    End With
    tempSht.Delete
End Sub
Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim DateString As String
    Dim FolderName As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ActiveWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "(dd-mm-yy)")
    FolderName = "F:\General Docs\Output" & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets
        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 And Left(sh.Name, 2) = shName Then
            sh.Select
        End If
    Next sh
    Sheets.Copy
    'Set Destwb to the new workbook
    Set Destwb = ActiveWorkbook

    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007
            If Sourcewb.Name = .Name Then
                MsgBox "Your answer is NO in the security dialog"
            Else
                Select Case Sourcewb.FileFormat
                    Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                    Case 52:
                        If .HasVBProject Then
                            FileExtStr = ".xlsm": FileFormatNum = 52
                        Else
                            FileExtStr = ".xlsx": FileFormatNum = 51
                        End If
                    Case 56: FileExtStr = ".xls": FileFormatNum = 56
                    Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End If
    End With

    'Change all cells in the worksheet to values if you want
    If Destwb.Sheets(1).ProtectContents = False Then
        With Destwb.Sheets(1).UsedRange
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
            .Cells(1).Select
        End With
        Application.CutCopyMode = False
    End If


    'Save the new workbook and close it
    With Destwb
        .SaveAs FolderName _
                & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                FileFormat:=FileFormatNum
        .Close False
    End With



    MsgBox "You can find the files in " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Hi Roy

Thanks for your input so far.

Sorry I forgot to mention... some worksheets have 3 characters, e.g. ABR and other just have 2 e.g. AG. The list generated therefore truncates some of these names. I tried changing to (sh.name, 3) in both the create list and copy_worksheet macro but that just produced a list with some duplicates.

When running main and calling the copy_worksheet macro, only one file is generated (containing all the worksheets) with the name of the first worksheet from current workbook . After that I get a Path/File Access Error.

It will be difficult to build a list of names because all the three letter names will appear in the list twice.

Hi again

How about a change of tack on this one..

Say I have 4 workbooks each with the same sheet name in each.

(e.g. WB1.xls has sheet 'AG', as does WB2.xls and so on.)

Is it possible that grab each worksheet with the same name from each workbook and save them together in one workbook? Please note that some sheets will have 3 initiaals instead of 2.

I figure that this script could be modified and looped to work with the copy script perhaps?

Cheers

Danny

Sub ImportWorkbooks()
Dim wbkInto As Workbook
Set wbkInto = ActiveWorkbook
Dim StartDirectory As String
StartDirectory = ActiveWorkbook.Path 'sets directory
ChDrive Left(StartDirectory, 1)
ChDir StartDirectory
Z = Application.GetOpenFilename(FileFilter:="Excel files (*.xls; *.xlsb; *.xlsm; *.xlsx), *.xls; *.xlsb; *.xlsm; *.xlsx", MultiSelect:=True)
'Open loop for action to be taken on all selected workbooks.
For x = 1 To UBound(Z)
Set WB = Workbooks.Open(Z(x))
WB.Sheets.Copy After:=wbkInto.Sheets(1)
WB.Close False
Next x
End Sub

Just physically copy each sheet to a new workbook if they match, or combine the data on each sheet to one?

That would be easiest, but considering I have 105 sheets x 4 workbooks - I'm having to manipulate around 420~ worksheets effectively. I wish they could be merged, but unfortunately they need to stay as separate worksheets.

At the moment (via macros and userforms) I am just importing these 4 large workbooks into one giant workbook and getting excel sort/add the suffixes (2), (3) etc. Then I am saving each worksheet as an individual workbook after which, a file/sheet listing is produced. This list is then automatically printed to the default printer.

Using the file list I manually have to recombine the sets of files into new workbooks (or 'Packs' as I can them) takes hours though.

maybe you could use a macro to first go through the first workbook and create individual workbooks in a subdirectory. Then use a separate macro to then open each remaining workbook match the sheets to the relevant workbook & copy the data to the end of each workbook's sheet.

Someone here has changed their mind and would rather work from one source, in that case I don't need to match from other workbooks.

In that sense its very easy for me to import all the worksheets into one workbook and create an array to select several sheets which I then bolt more code onto.

I've implemented this so far but the array only works when 4 sheets are present for each person - anything less is 'outside the range'

I'm a bit confused about the whole redim/preserve/erase thing. How could I rewrite this so excel knows to look to check for multiple arrays. Nesting this would be ok.

My four arrays would be.. (and I realise you wouldn't define them like this)

array1 = Sheets(Array(strname)).select
array2 = Sheets(Array(strname, strname & " (2)")).select
array3 = Sheets(Array(strname, strname & " (2)", strname & " (3)")).selectarray4 = Sheets(Array(strname, strname & " (2)", strname & " (3)", strname & " (4)")).select

Cheers


Danny

Function SheetExists(SheetName As String) As Boolean
 'returns TRUE if the sheet exists in the active workbook
    SheetExists = False
    On Error GoTo NoSuchSheet
    If Len(Sheets(SheetName).Name) > 0 Then
        SheetExists = True
        Exit Function
   End If
NoSuchSheet:
End Function
Sub SheetSelect()
Dim strname As String
Dim ThisBook As Workbook, WkSht As Worksheet
Set ThisBook = ThisWorkbook
   
strname = InputBox(Prompt:="Please enter user code.", _
          Title:="User Code Input")

If Not SheetExists(strname) Then
    MsgBox strname & " doesn't exist!"
Else
    For Each WkSht In ActiveWorkbook.Worksheets
        Select Case WkSht.Name
           
        Case strname, strname & " (2)", strname & " (3)", strname & " (4)"
            Application.DisplayAlerts = False
            Sheets(Array(strname, strname & " (2)", strname & " (3)", strname & " (4)")).Select
        Case Else
           ' Do Nothing
        End Select
Next WkSht
End If

End Sub