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

M

mummo

New Member
Joined
Apr 2, 2021
Messages
29
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

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Sort by date Sort by votes
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
 
Upvote 0
Solution
dmt32 said:
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
Click to expand...
Thank you!
Works just like needed.
 
Upvote 0
PerusTomi said:
Thank you!
Works just like needed.
Click to expand...

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
 
Upvote 0
dmt32 said:
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
Click to expand...
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
 
Upvote 0
PerusTomi said:
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
Click to expand...

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
 
Upvote 0
dmt32 said:
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
Click to expand...
Thank you again! Works great and greatly improves my work efficiency!
 
Upvote 0
dmt32 said:
your welcome - appreciate feedback

Dave
Click to expand...
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
 
Upvote 0
PerusTomi said:
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.
Click to expand...

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
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Solved
VBA to save a copy of a workbook with a cell reference including macros
Replies
1
Views
400
Domenic
D
R
  • Question
VBA to Copy Multiple sheets to new workbook & save as .xlsb or .xlsx
2
Replies
16
Views
629
rahildhody
R
B
  • Solved
VBA to save one file as multiple files in location
Replies
7
Views
606
bh24524
B
K
  • Question
VBA to filter Worksheet on manager column & copy all data to new workbook
Replies
8
Views
655
kizzie37
K
O
  • Solved
Mac OS Sonoma - Excel Macros failing since upgrade - SaveAs seems to be failing
2 3
Replies
26
Views
2K
toaruScar
T

Forum statistics

Threads
1,214,537
Messages
6,120,096
Members
448,944
Latest member
SarahSomethingExcel100

Share this page

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
Back
Top