Posts by TimDunn

Hi Roy,

Still no luck with the "Application.ActivePrinter" portion of the code. I will keep trying but wanted to drop back in to say Thank You again for all your help.

I appreciate your time and guidance.

Best Regards,

Tim

Hey Roy,

I think I have found a temporary solution. I didn't and still don't really want the user to have to do anything but fill in the blanks and hit submit but..... I made the changes below . We will have to make sure the printer we want to use is set up on the users kiosks if we end up using this until the Application.ActivePrinter is figured out. I have only tested it on my computer so far but will try it on one of the kiosks today. I appreciate your help and will keep trying to get the original plan to work in the meantime.

'If Application.ActivePrinter <> "NPI140D8A (HP LaserJet 400 M401n) on Ne00:" Then _
'Application.ActivePrinter = "NPI140D8A (HP LaserJet 400 M401n) on Ne00:"
Application.Dialogs(xlDialogPrinterSetup).Show
wsO.PrintOut
Application.ActivePrinter = CurrentPrinter

Same error, same line.

That is exactly as it is in my code module. "Then" is in blue while all the other text is in black.

It's the "Application.ActivePrinter" line right before the wsO.printout.

Sub Submit()
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("A1:I42").Copy
'~~> Paste it in say Cell A1. Change as applicable
wsO.Range("A1").PasteSpecial Paste:=xlPasteValues
wsO.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
wsO.Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
If Application.ActivePrinter <> "NPI140D8A (HP LaserJet 400 M401n) on Ne00:" Then _
Application.ActivePrinter = "NPI140D8A (HP LaserJet 400 M401n) on Ne00:"
wsO.PrintOut
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

Roy,

I plugged in what you sent and I still get the same run time error. I read where the port number (Ne00 in this case) will change from Ne00 thru Ne16. I verified that the printer I am testing with still had Ne00 before I tried the code.

I will keep trying. Thank you!!

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:

Dim CurrentPrinter as string
CurrentPrinter = Application.ActivePrinter

at top of code, and:

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.)

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

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

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

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

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!!

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)

Hi Roy,

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

"Compile Error:"

Expected Array

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

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

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

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

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

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

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.

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