VBA to save a copy with cell value name and chosen sheets

mummo

New Member
Joined
Apr 2, 2021
Messages
24
Office Version
  1. 365
Platform
  1. Windows
Hello!
I am pretty new to VBA an this is my first post here.
My problem is that I am trying to make a save button in file that has multiple sheets. I need it to save a copy of the open workbook in xlsx-format, with a name from A1 and remove one sheet from the copy. I have it working, but it flashes the excel on the screen before saving. It should save it in the background, not open it and keep the current workbook open without saving anything to the active workbook.
This is the current code:

Sub SaveOma()

Dim FileName As String
Dim Path As String
Dim NewWorkBook As Workbook
Dim OldWorkBook As Workbook
Set NewWorkBook = Workbooks.Add
Set OldWorkBook = ThisWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Path = "C:\Users\Tomi\Desktop\"
FileName = OldWorkBook.Sheets("Checklist and decision").Range("A1").Value & ".xlsx"

Dim x As Integer

For x = 2 To OldWorkBook.Worksheets.Count
OldWorkBook.Worksheets(x).Copy after:=NewWorkBook.Worksheets(NewWorkBook.Worksheets.Count)
Next x

NewWorkBook.Worksheets(1).Delete

NewWorkBook.SaveAs Path & FileName
NewWorkBook.Close

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub


Is there anything to add or improve so it would run more smoothly?
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,521
Office Version
  1. 2019
Platform
  1. Windows
Hi
welcome to forum

untested but try this update to your code & see if does what you want

VBA Code:
Sub SaveOma()
    Dim x           As Integer
    Dim FileName    As String, FilePath As String
    Dim NewWorkBook As Workbook, OldWorkBook As Workbook
    
    On Error GoTo myerror
    Set OldWorkBook = ThisWorkbook
    
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
    
    FilePath = "C:\Users\Tomi\Desktop\"
    FileName = OldWorkBook.Sheets("Checklist And decision").Range("A1").Value & ".xlsx"
    
    For x = 2 To OldWorkBook.Worksheets.Count
        With OldWorkBook.Worksheets(x)
            If Not NewWorkBook Is Nothing Then
                .Copy after:=NewWorkBook.Worksheets(NewWorkBook.Worksheets.Count)
            Else
                .Copy
                Set NewWorkBook = ActiveWorkbook
            End If
        End With
    Next x
    
    NewWorkBook.SaveAs FilePath & FileName
      
myerror:
   If Not NewWorkBook Is Nothing Then NewWorkBook.Close False
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Dave
 
Solution

mummo

New Member
Joined
Apr 2, 2021
Messages
24
Office Version
  1. 365
Platform
  1. Windows
Hi
welcome to forum

untested but try this update to your code & see if does what you want

VBA Code:
Sub SaveOma()
    Dim x           As Integer
    Dim FileName    As String, FilePath As String
    Dim NewWorkBook As Workbook, OldWorkBook As Workbook
   
    On Error GoTo myerror
    Set OldWorkBook = ThisWorkbook
   
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
   
    FilePath = "C:\Users\Tomi\Desktop\"
    FileName = OldWorkBook.Sheets("Checklist And decision").Range("A1").Value & ".xlsx"
   
    For x = 2 To OldWorkBook.Worksheets.Count
        With OldWorkBook.Worksheets(x)
            If Not NewWorkBook Is Nothing Then
                .Copy after:=NewWorkBook.Worksheets(NewWorkBook.Worksheets.Count)
            Else
                .Copy
                Set NewWorkBook = ActiveWorkbook
            End If
        End With
    Next x
   
    NewWorkBook.SaveAs FilePath & FileName
     
myerror:
   If Not NewWorkBook Is Nothing Then NewWorkBook.Close False
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Dave
Thank you!
Works just like needed.
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,521
Office Version
  1. 2019
Platform
  1. Windows
Thank you!
Works just like needed.

you are welcome glad update does what you want

I omitted to include the file format which should be included

Rich (BB code):
NewWorkBook.SaveAs FilePath & FileName, 51

just add 51 as shown in bold which is the numeric value for constant xlOpenXMLWorkbook (without macro's 2007 on, xlsx)

Dave
 

mummo

New Member
Joined
Apr 2, 2021
Messages
24
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

you are welcome glad update does what you want

I omitted to include the file format which should be included

Rich (BB code):
NewWorkBook.SaveAs FilePath & FileName, 51

just add 51 as shown in bold which is the numeric value for constant xlOpenXMLWorkbook (without macro's 2007 on, xlsx)

Dave
Hello again,
I was wondering is it possible to make this code also create new folder which is named same way as the file itself? I have been manually creating a new folder so far after every save
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,521
Office Version
  1. 2019
Platform
  1. Windows
Hello again,
I was wondering is it possible to make this code also create new folder which is named same way as the file itself? I have been manually creating a new folder so far after every save

Hi,
you can try including the MkDir statement in your code

Untested but try this update to the code.

Rich (BB code):
Sub SaveOma()
    Dim x           As Integer
    Dim FileName    As String, FilePath As String
    Dim NewWorkBook As Workbook, OldWorkBook As Workbook
   
    Set OldWorkBook = ThisWorkbook
   
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
   
    On Error Resume Next
    With OldWorkBook.Sheets("Checklist And decision")
        FilePath = "C:\Users\Tomi\Desktop\" & .Range("B1").Value
        FileName = .Range("A1").Value & ".xlsx"
    End With
   
    MkDir FilePath
    On Error GoTo -1
   
    On Error GoTo myerror
    FilePath = FilePath & "\"
   
    For x = 2 To OldWorkBook.Worksheets.Count
        With OldWorkBook.Worksheets(x)
            If Not NewWorkBook Is Nothing Then
                .Copy after:=NewWorkBook.Worksheets(NewWorkBook.Worksheets.Count)
            Else
                .Copy
                Set NewWorkBook = ActiveWorkbook
            End If
        End With
    Next x
   
    NewWorkBook.SaveAs FilePath & FileName, 51
       
     
myerror:
   If Not NewWorkBook Is Nothing Then NewWorkBook.Close False
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Note: MkDir will only create the last folder in the path if it does not already exist.

Change the range shown in RED BOLD that contains the folder name as required.

Dave
 

mummo

New Member
Joined
Apr 2, 2021
Messages
24
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Hi,
you can try including the MkDir statement in your code

Untested but try this update to the code.

Rich (BB code):
Sub SaveOma()
    Dim x           As Integer
    Dim FileName    As String, FilePath As String
    Dim NewWorkBook As Workbook, OldWorkBook As Workbook
  
    Set OldWorkBook = ThisWorkbook
  
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
  
    On Error Resume Next
    With OldWorkBook.Sheets("Checklist And decision")
        FilePath = "C:\Users\Tomi\Desktop\" & .Range("B1").Value
        FileName = .Range("A1").Value & ".xlsx"
    End With
  
    MkDir FilePath
    On Error GoTo -1
  
    On Error GoTo myerror
    FilePath = FilePath & "\"
  
    For x = 2 To OldWorkBook.Worksheets.Count
        With OldWorkBook.Worksheets(x)
            If Not NewWorkBook Is Nothing Then
                .Copy after:=NewWorkBook.Worksheets(NewWorkBook.Worksheets.Count)
            Else
                .Copy
                Set NewWorkBook = ActiveWorkbook
            End If
        End With
    Next x
  
    NewWorkBook.SaveAs FilePath & FileName, 51
      
    
myerror:
   If Not NewWorkBook Is Nothing Then NewWorkBook.Close False
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Note: MkDir will only create the last folder in the path if it does not already exist.

Change the range shown in RED BOLD that contains the folder name as required.

Dave
Thank you again! Works great and greatly improves my work efficiency!
 

mummo

New Member
Joined
Apr 2, 2021
Messages
24
Office Version
  1. 365
Platform
  1. Windows
your welcome - appreciate feedback

Dave
I have faced a new problem and I can't get it solved by any of the methods I googled, so once again I am here asking for help.

The new copy has links to the original workbook which there shouldn't be. The new excel should be workbook in it's own with working cell references within the workbook.

Hard for me to explain im english what I need to do, but I have several sheets that have references between them. I have to make calculations, save a copy and the next guy continues the calculations from the copy so the cell references would have to work.
The CSG-sheet is only a sheet with the macro buttons and no references to the other sheets.

Is there any fix for this? Below is the current code I got from here and just changed the path and sheet name.


VBA Code:
Sub SaveYleinen()

Dim x           As Integer

    Dim FileName    As String, FilePath As String

    Dim NewWorkBook As Workbook, OldWorkBook As Workbook

  

    Set OldWorkBook = ThisWorkbook

  

    With Application

        .ScreenUpdating = False: .DisplayAlerts = False

    End With

  

    On Error Resume Next

    With OldWorkBook.Sheets("CSG")

        FilePath = "L:\CS\Tomi Miettinen\Testi\" & .Range("B1").Value & .Range("B2").Value

        FileName = .Range("B1").Value & .Range("B2").Value & ".xlsx"

    End With

  

    MkDir FilePath

    On Error GoTo -1

  

    On Error GoTo myerror

    FilePath = FilePath & "\"

  

    For x = 2 To OldWorkBook.Worksheets.Count

        With OldWorkBook.Worksheets(x)

            If Not NewWorkBook Is Nothing Then

                .Copy after:=NewWorkBook.Worksheets(NewWorkBook.Worksheets.Count)

            Else

                .Copy

                Set NewWorkBook = ActiveWorkbook

            End If

        End With

    Next x

  

    NewWorkBook.SaveAs FilePath & FileName, 51

      

     

myerror:

   If Not NewWorkBook Is Nothing Then NewWorkBook.Close False

    With Application

        .ScreenUpdating = True: .DisplayAlerts = True

    End With

    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"

 

End Sub
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,521
Office Version
  1. 2019
Platform
  1. Windows
I have faced a new problem and I can't get it solved by any of the methods I googled, so once again I am here asking for help.

The new copy has links to the original workbook which there shouldn't be. The new excel should be workbook in it's own with working cell references within the workbook.

Hi
try following & see if helps

Place this code in standard module

VBA Code:
Sub BreakAllLinks(ByVal wb As Object)
    Dim MyLinks     As Variant
    Dim i           As Long
    With wb
        MyLinks = .LinkSources(Type:=xlLinkTypeExcelLinks)
        If IsArray(MyLinks) Then
            For i = LBound(MyLinks) To UBound(MyLinks)
                .BreakLink Name:=MyLinks(i), _
                           Type:=xlLinkTypeExcelLinks
            Next i
        End If
    End With
End Sub

Then in your main code add the following line just before the SaveAs line of code


Rich (BB code):
   BreakAllLinks NewWorkBook
    
    NewWorkBook.SaveAs FilePath & FileName, 51


Dave
 

Watch MrExcel Video

Forum statistics

Threads
1,130,117
Messages
5,640,203
Members
417,131
Latest member
Seanr19871

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top