VBA copy range to new workbook save as path and filename

TimDunn · Aug 20th 2020

Hello, My name is Tim.

I am working on a project and in need of some help.

I have created a form in excel and inserted a button to "submit" the form.

Submit in this case needs to accomplish the following:

Copy a range from the form and save it to a new workbook, Paste the formats and the values (form will have Vlookup formulas). So far the code below has worked for this part.

Save the new workbook using a specific path and filename. Filename to be derived from a cell on the form. I get a "Method 'SaveAs of Object'_Workbook' failed" error.

When I specify the path and a filename directly in the .saveas line it seems to work.

This is as far as I have gotten so far by piecing together code I have found online. Once this is working I would like to also send the copied range (new workbook) to a network printer.

I have not found or tried any code for that part yet but would welcome any help or suggestions.

I have attached the "Form" and the code I am working with is below.

Thank you in advance for any help and suggestions, both are greatly appreciated.

Code

Sub Submit()
  Dim wbI As Workbook, wbO As Workbook
  Dim wsI As Worksheet, wsO As Worksheet
  Dim path As String
  Dim filename1 As String

    '~~> Source/Input Workbook
    Set wbI = ThisWorkbook
    '~~> Set the relevant sheet from where you want to copy
    Set wsI = wbI.Sheets("Sheet1")

    '~~> Destination/Output Workbook
    Set wbO = Workbooks.Add

    With wbO
        '~~> Set the relevant sheet to where you want to paste
        Set wsO = wbO.Sheets("Sheet1")
        path = "y:\misc docs\"
        filename1 = Range("e7").Text
        '~~>. Save the file
        .SaveAs Filename:=path & filename1 & ".xls", FileFormat:=xlOpenXMLWorkbook
    'Code above fails, code below works but does not fit the need.
        '.SaveAs Filename:="y:\misc docs\reqtest3.xlsx", FileFormat:=xlOpenXMLWorkbook
        
        '~~> Copy the range
        wsI.Range("B1:I42").Copy
        
        
        '~~> Paste it in say Cell A1. Change as applicable
        wsO.Range("B1").PasteSpecial Paste:=xlPasteValues
        wsO.Range("b1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        wbO.Close Savechanges:=True
        
        Application.CutCopyMode = False
        
    End With
End Sub

Display More

**royUK** · Aug 21st 2020

Which sheet contains Range("e7").Text? You don't specify the sheet so Excel is trying yo use the activesheet.

What does that range actually contain?

TimDunn · Aug 21st 2020

Hi Roy,

I want to use "e7" from the original workbook as the filename on the new workbook.

"e7" will contain a unique value that is entered by the user.

Thanks very much

Tim

TimDunn · Aug 21st 2020

Hi Roy,

Quick update. I moved the path and filename code up under the "source/input workbook" in the code I sent you. (Edited code is below)

I changed the ".saveas" section back to use that path and filename and was able to generate a new workbook with the correct name.

When I went to open the new workbook I got a warning about mismatched file formats but was able to open the file. I then changed the .saveas file format to "52" and was able to create a new workbook and open it with no warnings or errors. Is there a way to save the new workbook as .xls or .xlsx without getting the warning message?

Thanks so much for your help!

Tim

Code

Sub Submit()
  Dim wbI As Workbook, wbO As Workbook
  Dim wsI As Worksheet, wsO As Worksheet
  Dim path As String
  Dim filename1 As String

    '~~> Source/Input Workbook
    Set wbI = ThisWorkbook
    path = "y:\misc docs\"
    filename1 = Range("e7").Text
    '~~> Set the relevant sheet from where you want to copy
    Set wsI = wbI.Sheets("Sheet1")
    
    '~~> Destination/Output Workbook
    Set wbO = Workbooks.Add

    With wbO
        '~~> Set the relevant sheet to where you want to paste
        Set wsO = wbO.Sheets("Sheet1")
        
        '~~>. Save the file
        .SaveAs Filename:=path & filename1 & ".xlsm", FileFormat:=52
        '.SaveAs Filename:="y:\misc docs\reqtest3.xlsx", FileFormat:=xlOpenXMLWorkbook
        
        '~~> Copy the range
        wsI.Range("B1:I42").Copy
        
        
        '~~> Paste it in say Cell A1. Change as applicable
        wsO.Range("B1").PasteSpecial Paste:=xlPasteValues
        wsO.Range("b1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        wbO.Close Savechanges:=True
        
        Application.CutCopyMode = False
        
    End With
End Sub

Display More

**royUK** · Aug 21st 2020

I would not declare a variable to refer to ThisWorkBook.

When you add a new workbook if it is xlsx or xlsm it will only have one sheet which will be the activesheet.

If you are saving as .xls you do not need to use fileformat, but it would be 56 with the xls extension.

What is the name in the cell, does it already have the file extension?

This works for me

Code

Sub Submit()
Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet, wsO As Worksheet
Dim path As String
Dim filename1 As String


'~~> Source/Input Workbook
Set wbI = ThisWorkbook
'~~> Set the relevant sheet from where you want to copy
Set wsI = wbI.Sheets("Sheet1")
path = "y:\misc docs\"
filename1 = ws1.Range("e7").Text


'~~> Destination/Output Workbook
Set wbO = Workbooks.Add


With wbO
'~~> Set the relevant sheet to where you want to paste
''/// this will actually be the activesheet
Set wsO = wbO.Sheets("Sheet1")


'~~>. Save the file
'51- xlsx no macros
'52- xlsm with macros
'56-xls
.SaveAs Filename:=path & filename1, FileFormat:=51
'.SaveAs Filename:="y:\misc docs\reqtest3.xlsx", FileFormat:=xlOpenXMLWorkbook


'~~> Copy the range
wsI.Range("B1:I42").Copy




'~~> Paste it in say Cell A1. Change as applicable
wsO.Range("B1").PasteSpecial Paste:=xlPasteValues
wsO.Range("b1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
wbO.Close Savechanges:=True


Application.CutCopyMode = False


End With
End Sub

Display More

TimDunn · Aug 21st 2020

Roy,

So far that works great! The info in "e7" is a work order number that the user will enter. A potential issue that I was just made aware of is that it is possible that a user may have to submit two forms (requisitions) using the same work order number ("e7"). I don't want to overwrite if the file already exists but would love to append to it if needed. Maybe with a -1, -2 etc.... I also still need to see if I can get the new workbook to print on a network printer as a part of the "submit" process. I don't want to wear out my welcome as I am extremely appreciative of your time and expertise. You have already put me WAY ahead of where I would have been. I will be researching the "if file exists" and printing tasks and would truly appreciate any advice or guidance you have on those topics.

Thank you for your invaluable assistance,

Tim

**royUK** · Aug 21st 2020

Here's a Function to test if a file exists

Code

Function FilExists(FilName As String) As Boolean
     FilExists = (Dir(FilName) > "")
End Function

Sub Test()
If FilExists("c:\MyWorkBook.xlsx") Then
''///do something
Else: MsgBox "The file does not exist"
End If
End Sub

TimDunn · Aug 24th 2020

Hi Roy,

So far, with your help, I have been able to save an identified range to a new workbook. (code below) The new workbook name is derived from a cell value in the original workbook. Concerns of duplicate file names prompted the need to check for existing files of the same name and to append the file name if the file already exists. I have tried to plug the code you sent me in to my existing code and I have been completely unsuccessful. I have no idea exactly where to insert the code and when I try I get an error telling me I have to end the original sub. I have searched this forum as well as others but to no avail. If the file exists, I want to append the file name and then save it. If the file does not exist (else) I assume the .saveas filename: in the existing could would work. I am completely confused at this point.

Thanks for any additional guidance.

Tim

Code

Sub Submit1()
Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet, wsO As Worksheet
Dim path As String
Dim filename1 As String
Application.ScreenUpdating = False
'~~> Source/Input Workbook
Set wbI = ThisWorkbook
'~~> Set the relevant sheet from where you want to copy
Set wsI = wbI.Sheets("Sheet1")
path = "y:\misc docs\"
filename1 = wsI.Range("e7").Text
'~~> Destination/Output Workbook
Set wbO = Workbooks.Add
With wbO
'~~> Set the relevant sheet to where you want to paste
''/// this will actually be the activesheet
Set wsO = wbO.Sheets("Sheet1")
'~~>. Save the file
'51- xlsx no macros
'52- xlsm with macros
'56-xls
.SaveAs Filename:=path & filename1, FileFormat:=51

'~~> Copy the range
wsI.Range("B1:I42").Copy
'~~> Paste it in say Cell A1. Change as applicable
wsO.Range("B1").PasteSpecial Paste:=xlPasteValues
wsO.Range("B1").PasteSpecial Paste:=xlPasteColumnWidths
wsO.Range("b1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
wbO.Close Savechanges:=True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With
If Err = 0 Then MsgBox "Requisition Submitted", vbInformation
End Sub

Display More

**royUK** · Aug 24th 2020

You would usually put the Function in a separate module. Try this

Code

Option Explicit


Sub Submit1()
Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet, wsO As Worksheet
Dim path As String
Dim filename1 As String
Application.ScreenUpdating = False
'~~> Source/Input Workbook
Set wbI = ThisWorkbook
'~~> Set the relevant sheet from where you want to copy
Set wsI = wbI.Sheets("Sheet1")
path = "y:\misc docs\"
filename1 = wsI.Range("e7").Text
'~~> Destination/Output Workbook
Set wbO = Workbooks.Add
With wbO
'~~> Set the relevant sheet to where you want to paste
''/// this will actually be the activesheet
Set wsO = wbO.Sheets("Sheet1")
'~~>. Save the file
'51- xlsx no macros
'52- xlsm with macros
'56-xls
If FilExists(path & filename1) Then filename1 = Right(filename1(Len(filename1) - 5) & (1))
.SaveAs Filename:=path & filename1, FileFormat:=51
'~~> Copy the range
wsI.Range("B1:I42").Copy
'~~> Paste it in say Cell A1. Change as applicable
wsO.Range("B1").PasteSpecial Paste:=xlPasteValues
wsO.Range("B1").PasteSpecial Paste:=xlPasteColumnWidths
wsO.Range("b1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
wbO.Close Savechanges:=True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With
If Err = 0 Then MsgBox "Requisition Submitted", vbInformation
End Sub
Function FilExists(FilName As String) As Boolean
FilExists = (Dir(FilName) > "")
End Function

Display More

TimDunn · Aug 24th 2020

Hi Roy,

Thanks so much for your prompt reply. I get the following error when compiling. Clip attached.

"Compile Error:"

Expected Array

**royUK** · Aug 24th 2020

What exactly is in the cell E7?

TimDunn · Aug 24th 2020

Cell E7 will contain a work order number that is entered by the user filling out the form. It is a unique number but may be duplicated if the user submits a second form for the same work order. (form is essentially a requisition or request for parts)

**royUK** · Aug 24th 2020

I thought it contained the full file name with extension. Try this

Code

Sub Submit1()
Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet, wsO As Worksheet
Dim path As String
Dim filename1 As String
Application.ScreenUpdating = False
'~~> Source/Input Workbook
Set wbI = ThisWorkbook
'~~> Set the relevant sheet from where you want to copy
Set wsI = wbI.Sheets("Sheet1")
path = "y:\misc docs\"
filename1 = wsI.Range("e7").Text
'~~> Destination/Output Workbook
Set wbO = Workbooks.Add
With wbO
'~~> Set the relevant sheet to where you want to paste
''/// this will actually be the activesheet
Set wsO = wbO.Sheets("Sheet1")
'~~>. Save the file
'51- xlsx no macros
'52- xlsm with macros
'56-xls
If FilExists(path & filename1) Then filename1 = filename1 & "(1)"
.SaveAs Filename:=path & filename1, FileFormat:=51
'~~> Copy the range
wsI.Range("B1:I42").Copy
'~~> Paste it in say Cell A1. Change as applicable
wsO.Range("B1").PasteSpecial Paste:=xlPasteValues
wsO.Range("B1").PasteSpecial Paste:=xlPasteColumnWidths
wsO.Range("b1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
wbO.Close Savechanges:=True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With
If Err = 0 Then MsgBox "Requisition Submitted", vbInformation
End Sub
Function FilExists(FilName As String) As Boolean
FilExists = (Dir(FilName) > "")
End Function

Display More

TimDunn · Aug 24th 2020

Hi Roy,

Sorry to be a pain. I get a file already exists message when I step through the code the second time. First pass creates the new workbook, copies the range, and saves the new workbook name based on the value in cell E7 with no problem. clip attached. If I say yes to the overwrite, it completes the macro with no further errors.

Thank you!!

**royUK** · Aug 24th 2020

This line checks if the file already exists, if not it should add(1) to the filename.

Code

If FilExists(path & filename1) Then filename1 = filename1 & "(1)"

There could be problems if multiple file names that are similar exist.

What do you get if you put msgbox filename1 immediately after that line?

TimDunn · Aug 24th 2020

MsgBox returns the filename of the file that already exists. File name is 777777 created on first run of the code. Other files in the directory from testing are sequential. 111111, 222222, 333333, etc....

Thank you,

Tim

**royUK** · Aug 24th 2020

It should b adding the (1). I can't see why it isn't working, I'll have to have another look tomorrow because I have to go out now.

TimDunn · Aug 24th 2020

Roy,

No worries, I appreciate all your help. Wonder if I might run another idea by you. While continuing to search for solutions, I ran across some information about appending a date and time to the saveas file name. I changed the line of code to read:

.SaveAs Filename:=path & filename1 & Format (Now(), "MMDDYY hhmmss"), FileFormat:=51

I ran a half dozen tests and so far it saves each file with a unique file name. As long as each name contains the value from E7, I don't have any issues with the file names. Are there any hidden gotcha's I should be cautious of? Would really appreciate your opinion of that methodology. If that would work then the last piece of the puzzle would be getting it to print to a network printer. I will continue to see what I can find on that.

Thank you again,

Tim

**royUK** · Aug 25th 2020

That's the best way to do it.

TimDunn · Aug 26th 2020

Hi Roy,

Thank you!! Seems to be working great so far. I am still trying to figure out how to get the new sheet to print to a network printer.

Added:

Code

Dim CurrentPrinter as string
CurrentPrinter = Application.ActivePrinter

at top of code, and:

Code

Application.ActivePrinter = "NPI140D8A (HP LaserJet 400 M401n) on Ne00:" ' (obtained this by running a quick sub to show Application.ActivePrinter on a pc in my building to use it for testing.)

Code

wsO.PrintOut , preview = False
Application.ActivePrinter = CurrentPrinter

after the PasteSpecial statements.

Code attached keeps getting: Run-Time error 1004 Method "ActivePrinter" of object'_Application' failed

I have tried multiple variations but am not having any luck.

Any suggestion would be greatly appreciated.

Thank you,

Tim

Code

Sub Submit1WithPrint()
Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet, wsO As Worksheet
Dim path As String
Dim filename1 As String
Dim CurrentPrinter As String
CurrentPrinter = Application.ActivePrinter
Application.ScreenUpdating = False
'~~> Source/Input Workbook
Set wbI = ThisWorkbook
'~~> Set the relevant sheet from where you want to copy
Set wsI = wbI.Sheets("Sheet1")
path = "y:\misc docs\"
filename1 = wsI.Range("e7").Text
'~~> Destination/Output Workbook
Set wbO = Workbooks.Add
With wbO
'~~> Set the relevant sheet to where you want to paste
''/// this will actually be the activesheet
Set wsO = wbO.Sheets("Sheet1")
'~~>. Save the file
'51- xlsx no macros
'52- xlsm with macros
'56-xls
.SaveAs Filename:=path & filename1 & Format(Now(), "MMDDYY hhmmss"), FileFormat:=51
'.SaveAs Filename:="y:\misc docs\reqtest3.xlsx", FileFormat:=xlOpenXMLWorkbook

'~~> Copy the range
wsI.Range("B1:I42").Copy
'~~> Paste it in say Cell A1. Change as applicable
wsO.Range("B1").PasteSpecial Paste:=xlPasteValues
wsO.Range("B1").PasteSpecial Paste:=xlPasteColumnWidths
wsO.Range("b1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.ActivePrinter = "NPI140D8A (HP LaserJet 400 M401n) on Ne00:"
wsO.PrintOut , preview = False
Application.ActivePrinter = CurrentPrinter
wbO.Close Savechanges:=True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With

If Err = 0 Then MsgBox "Requisition Submitted", vbInformation
End Sub

Display More

VBA copy range to new workbook save as path and filename

Participate now!

Share

Tags