VBA to Split Workbook: No Longer Working with Multi-Selection on User Form

[AliGW]

Having solved the values issue in my previous thread, I now have a new problem.

Previous thread: https://www.excelforum.com/excel-pro...to-values.html

The code I have used to work as I wished: I was able to CTRL select one or more sheets in the user form at the beginning and these would be copied and split out as separate files. Now, if I multi-select, it only works for the first sheet, after which I get copies of the last tab in the workbook instead of the other sheets I've selected. The subsequent sheets are copied, but when it comes to splitting out, it doesn't happen.


Only this line of code executes correctly on the subsequent sheets:

.Range("H1").Value = LstPrint.List(x)

What do I need to tweak to get it to loop back to the splitting out section for each sheet? I am not able to upload a workbook at the moment as I am at work.

My code is here:

Private Sub UserForm_Initialize()
Dim sh As Worksheet
With LstPrint
    .Clear
    For Each sh In Worksheets
        If sh.Name <> "1. Staff List & Subjects" And sh.Name <> "2. Staff Allocation Checklist" And sh.Name <> "3. Roles & Responsibilities" And sh.Name <> "Proforma" And sh.Name <> "Rooms" Then .AddItem sh.Name
    Next
End With
End Sub

Private Sub CmdPrint_Click()
    Dim DateString As String
    Dim FolderName As String
    Dim x As Long
    Dim FileFormatNum As Long

    Application.ScreenUpdating = False
    DateString = Format(Now, "dd mmmm yyyy")
    FolderName = "C:\Users\Alison\OneDrive - Royal Hospital School\Documents\Timetable WIP\2019-20\Staffing Grids for HoDs" & " " & DateString
    For x = 0 To LstPrint.ListCount - 1
        If LstPrint.Selected(x) = True Then
            Application.CopyObjectsWithCells = False
            With Sheets(LstPrint.List(x))
                If .ProtectContents = True Then
                    .Unprotect
                    .Copy , Sheets(Sheets.Count)
                    .Protect
                Else
                    .Copy Sheets(Sheets.Count)
                End If
            End With
            Application.CopyObjectsWithCells = True
            With Sheets(Sheets.Count)
                .Range("H1").Value = LstPrint.List(x)
                .Range("A1").Value = .Range("A1").Value
                .Range("B2:U4").Value = .Range("B2:U4").Value
                .Range("E94:U104").Value = .Range("E94:U104").Value
                .Copy
            End With
            With ActiveWorkbook
                .Sheets(1).Protect
                .Sheets(1).Name = LstPrint.List(x)
                If .HasVBProject Then
                    FileFormatNum = 52
                Else
                    FileFormatNum = 51
                End If
                .SaveAs FolderName & "\" & LstPrint.List(x), FileFormatNum
                .Close False
            End With
        End If
    Next
    Application.DisplayAlerts = False
    Sheets(Sheets.Count).Delete
    Application.DisplayAlerts = True
    Call Shell("explorer.exe " & FolderName, vbNormalFocus)
    Application.ScreenUpdating = True
    Unload Me
    Application.Goto Sheets("1. Staff List & Subjects").Range("A1")
End Sub

[bakerman2]

Posted answer in previous thread.

My bad.

Put this part

    Application.DisplayAlerts = False
    Sheets(Sheets.Count).Delete
    Application.DisplayAlerts = True

just above next.

[AliGW]

It's a good job I had a backup of the file!

It has worked, BUT it has deleted many worksheets from the source file!

[AliGW]

I'll try it - thanks!

[bakerman2]

Damn. Should slow myself down and look better. Sorry.

Private Sub CmdPrint_Click()
    Dim DateString As String
    Dim FolderName As String
    Dim x As Long
    Dim FileFormatNum As Long

    Application.ScreenUpdating = False
    DateString = Format(Now, "dd mmmm yyyy")
    FolderName = "C:\Users\Alison\OneDrive - Royal Hospital School\Documents\Timetable WIP\2019-20\Staffing Grids for HoDs" & " " & DateString
    For x = 0 To LstPrint.ListCount - 1
        If LstPrint.Selected(x) = True Then
            Application.CopyObjectsWithCells = False
            With Sheets(LstPrint.List(x))
                If .ProtectContents = True Then
                    .Unprotect
                    .Copy , Sheets(Sheets.Count)
                    .Protect
                Else
                    .Copy Sheets(Sheets.Count)
                End If
            End With
            Application.CopyObjectsWithCells = True
            With Sheets(Sheets.Count)
                .Range("H1").Value = LstPrint.List(x)
                .Range("A1").Value = .Range("A1").Value
                .Range("B2:U4").Value = .Range("B2:U4").Value
                .Range("E94:U104").Value = .Range("E94:U104").Value
                .Copy
            End With
            With ActiveWorkbook
                .Sheets(1).Protect
                .Sheets(1).Name = LstPrint.List(x)
                If .HasVBProject Then
                    FileFormatNum = 52
                Else
                    FileFormatNum = 51
                End If
                .SaveAs FolderName & "\" & LstPrint.List(x), FileFormatNum
                .Close False
            End With
            Application.DisplayAlerts = False
            Sheets(Sheets.Count).Delete
            Application.DisplayAlerts = True
        End If
    Next
    Call Shell("explorer.exe " & FolderName, vbNormalFocus)
    Application.ScreenUpdating = True
    Unload Me
    Application.Goto Sheets("1. Staff List & Subjects").Range("A1")
End Sub

[bakerman2]

OK.

BTW Thanks for rep+ on previous thread, much, much appreciated.

[AliGW]

No, this doesn't quite work - sorry.

For the first sheet I have selected, it copies out the LAST sheet in the workbook. For the second and third sheets I selected at the same time, it works. It has also left a copy of the last sheet selected in the source workbook.

Nearly but not quite!

[bakerman2]

Made a dummy file to show it should work.

Change path in range E1 before running.

[AliGW]

OK - I'll have a look. Thanks.

[AliGW]

I think I can only demonstrate the problem with the original file - it is going to take some time for me to create a copy that I can share.

[AliGW]

I don't understand what I am supposed to put in cell E1 - what path and why?

The folder is defined here:

FolderName = "C:\Users\Alison\OneDrive - Royal Hospital School\Documents\Timetable WIP\2019-20\Staffing Grids for HoDs" & " " & DateString

Very confused.

Anyway, it isn't working in the original file, which I cannot share. I will try to create a mock-up that shows the problem.

[AliGW]

It won't even work right for one sheet now, let alone two or more!

If I select the first sheet in the user form list, it gets copied into the source file, but then the sheet that gets stripped out is the LAST tab in the workbook, which is then deleted from the workbook. I am really confused.

[AliGW]

With a lot of trial and error, I have got it working.

The final code is:

Private Sub UserForm_Initialize()
Dim sh As Worksheet
With LstPrint
    .Clear
    For Each sh In Worksheets
        If sh.Name <> "1. Staff List & Subjects" And sh.Name <> "2. Staff Allocation Checklist" And sh.Name <> "3. Roles & Responsibilities" And sh.Name <> "Proforma" And sh.Name <> "Rooms" Then .AddItem sh.Name
    Next
End With
End Sub

Private Sub CmdPrint_Click()
    Dim DateString As String
    Dim FolderName As String
    Dim x As Long
    Dim FileFormatNum As Long

    Application.ScreenUpdating = False
    DateString = Format(Now, "dd mmmm yyyy")
    FolderName = "C:\Users\Alison\OneDrive - Royal Hospital School\Documents\Timetable WIP\2019-20\Staffing Grids for HoDs" & " " & DateString
    For x = 0 To LstPrint.ListCount - 1
        If LstPrint.Selected(x) = True Then
            Application.CopyObjectsWithCells = False
            With Sheets(LstPrint.List(x))
                    .Unprotect
                    .Copy
            End With
            Application.CopyObjectsWithCells = False
            With Sheets(Sheets.Count)
                .Unprotect
                .Range("H1").Value = LstPrint.List(x)
                .Range("A1").Value = .Range("A1").Value
                .Range("B2:U4").Value = .Range("B2:U4").Value
                .Range("E94:U104").Value = .Range("E94:U104").Value
                .Protect
            End With
            With ActiveWorkbook
                .Sheets(Sheets.Count).Protect
                .Sheets(Sheets.Count).Name = LstPrint.List(x)
                If .HasVBProject Then
                    FileFormatNum = 52
                Else
                    FileFormatNum = 51
                End If
                .SaveAs FolderName & "\" & LstPrint.List(x), FileFormatNum
                .Close False
                        End With
        For Each Sheet In ActiveWorkbook.Worksheets
            If Sheet.Name = LstPrint.List(x) & " (#)" Then
                Application.DisplayAlerts = False
                Worksheets(LstPrint.List(x) & " (#)").Delete
                Application.DisplayAlerts = True
            End If
        Next Sheet
        End If
    Next
    Application.ScreenUpdating = True
    Unload Me
    Application.Goto Sheets("1. Staff List & Subjects").Range("A1")
    Call Shell("explorer.exe " & FolderName, vbNormalFocus)
End Sub

Thanks for the help!

[AliGW]

I am making progress.

With the code below I can produce one or more sheets without sheets being deleted unnecessarily or extraneous sheets being left in the workbook. The only problem remaining is that everything below row 1 is copied from the first sheet in the user form list, not the sheet selected. Can anyone spot why the code is not looping through the sheets?

Private Sub CmdPrint_Click()
    Dim DateString As String
    Dim FolderName As String
    Dim x As Long
    Dim FileFormatNum As Long

    Application.ScreenUpdating = False
    DateString = Format(Now, "dd mmmm yyyy")
    FolderName = "C:\Users\Alison\OneDrive - Royal Hospital School\Documents\Timetable WIP\2019-20\Staffing Grids for HoDs" & " " & DateString
    For x = 0 To LstPrint.ListCount - 1
        If LstPrint.Selected(x) = True Then
            Application.CopyObjectsWithCells = False
            With Sheets(LstPrint.List(x))
                'If .ProtectContents = True Then
                    .Unprotect
                    .Copy Sheets(Sheets.Count)
                    '.Protect
                'Else
                    '.Copy Sheets(Sheets.Count)
                'End If
            End With
            Application.CopyObjectsWithCells = False
            With Sheets(Sheets.Count)
            'With Sheets(LstPrint.List(x))
                .Unprotect
                .Range("H1").Value = LstPrint.List(x)
                .Range("A1").Value = .Range("A1").Value
                .Range("B2:U4").Value = .Range("B2:U4").Value
                .Range("E94:U104").Value = .Range("E94:U104").Value
                .Copy
                .Protect
            End With
            With ActiveWorkbook
                .Sheets(Sheets.Count).Protect
                .Sheets(Sheets.Count).Name = LstPrint.List(x)
                If .HasVBProject Then
                    FileFormatNum = 52
                Else
                    FileFormatNum = 51
                End If
                .SaveAs FolderName & "\" & LstPrint.List(x), FileFormatNum
                .Close False
            End With
            Application.DisplayAlerts = False
            Worksheets(LstPrint.List(x) & " (2)").Delete
            Application.DisplayAlerts = True
        End If
    Next
    'Application.DisplayAlerts = False
    'Sheets(Sheets.Count).Delete
    'Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Unload Me
    Application.Goto Sheets("1. Staff List & Subjects").Range("A1")
    Call Shell("explorer.exe " & FolderName, vbNormalFocus)
End Sub

[bakerman2]

Hey Ali, sorry I wasn't there for the final stretch but I always work at night so I usually take a nap in the afternoon.

Going over your final code I found the line that was causing everything going sideways.

If you want to put in the time and effort could you please run below code, just for my peace of mind.

Private Sub CmdPrint_Click()
    Dim DateString As String
    Dim FolderName As String
    Dim x As Long
    Dim FileFormatNum As Long

    Application.ScreenUpdating = False
    DateString = Format(Now, "dd mmmm yyyy")
    FolderName = "C:\Users\Alison\OneDrive - Royal Hospital School\Documents\Timetable WIP\2019-20\Staffing Grids for HoDs" & " " & DateString
    For x = 0 To LstPrint.ListCount - 1
        If LstPrint.Selected(x) = True Then
            Application.CopyObjectsWithCells = False
            With Sheets(LstPrint.List(x))
                If .ProtectContents = True Then
                    .Unprotect
                    .Copy , Sheets(Sheets.Count)
                    .Protect
                Else
                    .Copy , Sheets(Sheets.Count)
                End If
            End With
            Application.CopyObjectsWithCells = True
            With Sheets(Sheets.Count)
                .Unprotect
                .Range("H1").Value = LstPrint.List(x)
                .Range("B2:U4").Value = .Range("B2:U4").Value
                .Range("E94:U104").Value = .Range("E94:U104").Value
                .Copy
            End With
            With ActiveWorkbook
                .Sheets(1).Protect
                .Sheets(1).Name = LstPrint.List(x)
                If .HasVBProject Then
                    FileFormatNum = 52
                Else
                    FileFormatNum = 51
                End If
                .SaveAs FolderName & "\" & LstPrint.List(x), FileFormatNum
                .Close False
            End With
            Application.DisplayAlerts = False
            Sheets(Sheets.Count).Delete
            Application.DisplayAlerts = True
        End If
    Next
    Application.ScreenUpdating = True
    Unload Me
    Application.Goto Sheets("1. Staff List & Subjects").Range("A1")
    Call Shell("explorer.exe " & FolderName, vbNormalFocus)
End Sub

[AliGW]

Yes, your new code seems to work. Can you explain what you changed and why?

[AliGW]

Thanks, Rudi. I will try it, but can you tell me the line that was screwing everything up? I have spent some time adding some bells and whistles this morning, so I don't want to mess everything up again. I'll try this on a backup copy.

Thanks for looking at it again - I will let you know shortly.

My code now looks like this (I am quite proud of it as a VBA novice):

Private Sub CheckBox1_Click()
    Dim N As Single
    If CheckBox1.Value = True Then
        For N = 0 To LstPrint.ListCount - 1
        LstPrint.Selected(N) = True
        Next N
    Else
        For N = 0 To LstPrint.ListCount - 1
        LstPrint.Selected(N) = False
        Next N
    End If
End Sub

Private Sub UserForm_Initialize()
Dim sh As Worksheet
With LstPrint
    .Clear
    For Each sh In Worksheets 'Sets worksheets to be excluded from selection list
        If sh.Name <> "1. Staff List & Subjects" And sh.Name <> "2. Staff Allocation Checklist" And sh.Name <> "3. Roles & Responsibilities" And sh.Name <> "Proforma" Then .AddItem sh.Name
    Next
End With
End Sub

Private Sub CmdPrint_Click()
    Dim DateString As String
    Dim FolderName As String
    Dim x As Long 'Sets the count of workbooks selected for export
    Dim i As Long 'Sets the workbookt o scroll all worksheets back to the top before exporting
    Dim FileFormatNum As Long

    Application.ScreenUpdating = False
    DateString = Format(Now, "dd mmmm yyyy")
    FolderName = "C:\Users\Alison\OneDrive - Royal Hospital School\Documents\Timetable WIP\2019-20\Staffing Grids for HoDs" & " " & DateString
    For x = 0 To LstPrint.ListCount - 1
    For i = 1 To ThisWorkbook.Sheets.Count
    Application.Goto reference:=Sheets(i).Range("A1"), Scroll:=True
    Next i
    
'///// COPY SECTION /////

        If LstPrint.Selected(x) = True Then
            Application.CopyObjectsWithCells = False
            With Sheets(LstPrint.List(x))
                    .Unprotect
                    .Copy
            End With
            
'///// PASTE SECTION /////

            Application.CopyObjectsWithCells = False
            With Sheets(Sheets.Count)
                .Unprotect
                .Range("H1").Value = LstPrint.List(x)
                .Range("A1").Value = .Range("A1").Value
                .Range("B2:U4").Value = .Range("B2:U4").Value
                .Range("E94:U104").Value = .Range("E94:U104").Value
                .Protect
            End With
            
'///// EXPORT SECTION /////

            With ActiveWorkbook
                .Sheets(Sheets.Count).Protect
                .Sheets(Sheets.Count).Name = LstPrint.List(x)
                If .HasVBProject Then
                    FileFormatNum = 52
                Else
                    FileFormatNum = 51
                End If
                .SaveAs FolderName & "\" & LstPrint.List(x), FileFormatNum
                .Close False
                        End With
                        
'///// TIDY WORKBOOK SECTION /////

        For Each Sheet In ActiveWorkbook.Worksheets
            If Sheet.Name = LstPrint.List(x) & " (#)" Then
                Application.DisplayAlerts = False
                Worksheets(LstPrint.List(x) & " (#)").Delete
                Application.DisplayAlerts = True
            End If
        Next Sheet
        End If
    Next
    
'///// RESET FOCUS SECTION /////

    Application.ScreenUpdating = True
    Unload Me 'Unloads user form
    Application.Goto Sheets("1. Staff List & Subjects").Range("A1") 'Returns focus to first sheet of workbook
    Call Shell("explorer.exe " & FolderName, vbNormalFocus) 'Opens folder containing esported workbooks
End Sub

[bakerman2]

Copy has two arguments.

Copy Before, After

Somewhere along the way we lost the comma and it looked like this

.Copy Sheets. Count

this copied the sheet BEFORE the last sheet making the rest of the code go belly-up.

It should have looked like this

.Copy , Sheet.Count

copying the sheet AFTER the last sheet so Sheets(Sheets.count) refferred to the copied sheet.

[bakerman2]

            With Sheets(LstPrint.List(x))
                    .Unprotect
                    .Copy
            End With

Doesn't the original sheet needs to be protected again because now you leave it unprotected ?

[AliGW]

Doesn't the original sheet needs to be protected again because now you leave it unprotected ?

No - it doesn't matter in the original master workbook, and I have left it out deliberately. Only I have access to it. It's the exported sheets that need the protection.

[AliGW]

Interesting. I will update my new code with this and see if it will execute correctly. Thanks for explaining! I'll let you know how it goes.

[AliGW]

Hi, Rudi!

It doesn't work in my master file. The code stops at this line:

                .Sheets(1).Name = LstPrint.List(x)

Please don't spend any more time on this - the code I ended up with in post #16 does work, and having tested it extensively, I am happy with it. I am not going to fiddle with it any more.

Thanks again for your very valuable insights. Have a nice day!