Create new workbook for each worksheet as value

[Nepur]

Hi there, I am trying to create a new workbook for each worksheet in an existing file with the resulting workbooks maintaining the formats but no formulas. I am using trying to use the below code but get errors at the pastespecial line codes. Is this something someone can help with?

Private Sub CommandButton1_Click()
Dim a As Integer
Dim ws As Worksheet
Dim wb As Workbook

a = ThisWorkbook.Worksheets.Count

For i = 1 To a
If ThisWorkbook.Worksheets(i).Name <> "Cells to review" Then
'If InStr(ThisWorkbook.Worksheets(i).Name, <> "Cell") Then

Set wb = Workbooks.Add
ThisWorkbook.Worksheets(i).Copy before:=wb.Worksheets(1)
ThisWorkbook.Worksheets(i).PasteSpecial xlPasteValues
ThisWorkbook.Worksheets(i).PasteSpecial xlPasteFormats
wb.SaveAs "C:\P&L-Summary" & "\" & ActiveSheet.Name & ".xlsm", 52

wb.Close savechanges = True
End If
Next i

ThisWorkbook.Activate
ThisWorkbook.Worksheets("Cells to review").Activate
ThisWorkbook.Worksheets("Cells to review").Cells(1, 1).Select

MsgBox ("Files created")
End Sub

 

[rlv01]

Welcome to mrexcel. Try this. (btw, try to use code tags when posting code. It helps with readability)

Private Sub CommandButton1_Click()
    Dim a As Integer, i As Integer, Cnt As Integer
    Dim ws As Worksheet
    Dim wb As Workbook
    
    a = ThisWorkbook.Worksheets.Count
    Cnt = 0
    
    For i = 1 To a
        If ThisWorkbook.Worksheets(i).Name <> "Cells to review" Then
            'If InStr(ThisWorkbook.Worksheets(i).Name, <> "Cell") Then
            
            Set wb = Workbooks.Add
            Set ws = wb.Worksheets(1)
            
            With ThisWorkbook.Worksheets(i)
                .UsedRange.Copy
                ws.Range("A1").PasteSpecial xlPasteValues
                ws.Range("A1").PasteSpecial xlPasteFormats
                
                wb.SaveAs "C:\P&L-Summary" & "\" & .Name & ".xlsm", 52
                wb.Close SaveChanges:=True
                Cnt = Cnt + 1
            End With
        End If
    Next i
    
    ThisWorkbook.Activate
    ThisWorkbook.Worksheets("Cells to review").Activate
    ThisWorkbook.Worksheets("Cells to review").Cells(1, 1).Select
    
    MsgBox (Cnt & " Files created")
End Sub

 

[Nepur]

Thank you "rlv01"for your time to help with my query. I am new to this so please bear with me. I am also not sure of how the tagging works but will look into this.The code works with these exceptions:
- The sheet name is not copied over from the source worksheet and therefore the workbooks being created are all named Sheet 1 and therefore get message that the file already exists and do i want to replace.
- Formats get copied with the xlPasteFormats code, but I loose the column widths from the source file.

I tried using :
.UsedRange.Copy ws.Range("A1")
'ws.Range("A1").PasteSpecial xlPasteValues
without the use of PasteSpecial xlPasteFormats which retains the column widths when pasting and but the grid lines are showing (the source has grid lines disabled from view)

Any further help would be greatly appreciated.
Thank you.

 

[rlv01]

Thank you "rlv01"for your time to help with my query. I am new to this so please bear with me. I am also not sure of how the tagging works but will look into this.

As a courtesy to others, you should look into this sooner rather than later. Here the section in the board FAQ

How to Post Your VBA Code

Post your VBA code.

www.mrexcel.com

.The code works with these exceptions:
- The sheet name is not copied over from the source worksheet and therefore the workbooks being created are all named Sheet 1 and therefore get message that the file already exists and do i want to replace.
- Formats get copied with the xlPasteFormats code, but I loose the column widths from the source file.

Try the modified code below.

Private Sub CommandButton1_Click()
    Dim a As Integer, i As Integer, Cnt As Integer
    Dim ws As Worksheet
    Dim wb As Workbook
    
    a = ThisWorkbook.Worksheets.Count
    Cnt = 0
    
    For i = 1 To a
        If ThisWorkbook.Worksheets(i).Name <> "Cells to review" Then
            'If InStr(ThisWorkbook.Worksheets(i).Name, <> "Cell") Then
            
            Set wb = Workbooks.Add
            Set ws = wb.Worksheets(1)
            
            With ThisWorkbook.Worksheets(i)
                On Error Resume Next
                ws.Name = .Name 'use the original sheet name unless there is a name conflict
                On Error GoTo 0
                
                .UsedRange.Copy
                ws.Range("A1").PasteSpecial xlPasteValues
                ws.Range("A1").PasteSpecial xlPasteFormats
                ws.Range("A1").PasteSpecial xlPasteColumnWidths 'paste column widths
                
                wb.SaveAs "C:\P&L-Summary" & "\" & .Name & ".xlsm", 52
                wb.Close SaveChanges:=True
                Cnt = Cnt + 1
            End With
        End If
    Next i
    
    ThisWorkbook.Activate
    ThisWorkbook.Worksheets("Cells to review").Activate
    ThisWorkbook.Worksheets("Cells to review").Cells(1, 1).Select
    
    MsgBox (Cnt & " Files created")
End Sub

 

[Nepur]

Hi there,

Thank you for the updated code and it works, however the formatting does not come through as desired. Some of the rows height come through as too big. The code below gives me the result I am after, except I cannot work out how to save the whole resulting worksheet with just the data as values rather then formulas. The source worksheets include formulas and a bar chart. Any thoughts on being able to use the below code and turning every cell that has a formula into a value?

Private Sub CommandButton1_Click()
Dim a As Integer
Dim ws As Worksheet
Dim wb As Workbook

a = ThisWorkbook.Worksheets.Count

For i = 1 To a
If ThisWorkbook.Worksheets(i).Name <> "Cells to review" Then

Set wb = Workbooks.Add
ThisWorkbook.Worksheets(i).Copy before:=wb.Worksheets(1)
wb.SaveAs "C:\P&L-Summary" & "\" & ActiveSheet.Name & ".xlsm", 52

wb.Close savechanges = True
End If
Next i

ThisWorkbook.Activate
ThisWorkbook.Worksheets("Cells to review").Activate
ThisWorkbook.Worksheets("Cells to review").Cells(1, 1).Select

MsgBox ("Files created")
End Sub

 

[rlv01]

Something like this perhaps

            ThisWorkbook.Worksheets(i).Copy before:=wb.Worksheets(1)
            
            With wb.Worksheets(ThisWorkbook.Worksheets(i).Name)
                .UsedRange.Copy
                .Range("A1").PasteSpecial xlPasteValues
            End With
            
            wb.SaveAs "C:\P&L-Summary" & "\" & ActiveSheet.Name & ".xlsm", 52

 

[Nepur]

Hi rlv01,

Amending the code with your suggested, I am getting run time error as below and the

.Range("A1").PasteSpecial xlPasteValues

gets highlighted. Any ideas what I might try to resolve?

 

[rlv01]

It works for me when I test it. I think you will need to repost the entire sub with the added code, so I can see how you added it.

 

[Nepur]

Hi there, here is the entire code

Private Sub CommandButton1_Click()
Dim a As Integer
Dim ws As Worksheet
Dim wb As Workbook

a = ThisWorkbook.Worksheets.Count

For i = 1 To a
If ThisWorkbook.Worksheets(i).Name <> "Cells to review" Then
'If InStr(ThisWorkbook.Worksheets(i).Name, <> "Cell") Then

Set wb = Workbooks.Add
ThisWorkbook.Worksheets(i).Copy before:=wb.Worksheets(1)
With wb.Worksheets(ThisWorkbook.Worksheets(i).Name)
                .UsedRange.Copy
                .Range("A1").PasteSpecial xlPasteValues
            End With

wb.SaveAs "C:\P&L-Summary" & "\" & ActiveSheet.Name & ".xlsm", 52

wb.Close savechanges = True
End If
Next i
 
ThisWorkbook.Activate
ThisWorkbook.Worksheets("Cells to review").Activate
ThisWorkbook.Worksheets("Cells to review").Cells(1, 1).Select

MsgBox ("Files created")
End Sub

 

[rlv01]

Nothing seems wrong and the code runs fine for me as-is. Try this version which has some error checking built in.

Private Sub CommandButton1_Click()
    Dim a As Integer, i As Integer
    Dim ws As Worksheet
    Dim wsName As String, S As String
    Dim wb As Workbook
    
    
    a = ThisWorkbook.Worksheets.Count
    
    Application.ScreenUpdating = False
    For i = 1 To a
        If ThisWorkbook.Worksheets(i).Name <> "Cells to review" Then
            Set ws = Nothing
            wsName = ThisWorkbook.Worksheets(i).Name
            
            Set wb = Workbooks.Add
            ThisWorkbook.Worksheets(wsName).Copy before:=wb.Worksheets(1)
            
            'Test for copy success
            On Error Resume Next
            Set ws = wb.Worksheets(wsName)
            On Error GoTo 0
            
            If Not ws Is Nothing Then
                With ws
                    .UsedRange.Copy
                    .Range("A1").PasteSpecial Paste:=xlPasteValues
                End With
                
                Application.DisplayAlerts = False
                wb.SaveAs "C:\P&L-Summary" & "\" & ActiveSheet.Name & ".xlsm", 52
                S = S & wb.Name & vbCr
                Application.DisplayAlerts = True
            Else
                Select Case MsgBox("Worksheet '" & wsName & "' did not get copied to workbook '" & wb.Name & "'" & vbCr & vbCr _
                        & "Continue?", vbOKCancel Or vbCritical, "Copy Failure")
                    Case vbCancel
                        Exit Sub
                End Select
            End If
            wb.Close False
        End If
    Next i
    Application.ScreenUpdating = True
    
    ThisWorkbook.Activate
    ThisWorkbook.Worksheets("Cells to review").Activate
    ThisWorkbook.Worksheets("Cells to review").Cells(1, 1).Select
    
    MsgBox ("Files created:" & vbCr & S)
End Sub