PDA

View Full Version : [SOLVED] Copy Module to New Workbook



Marhier
10-26-2017, 01:40 AM
Good morning all.
I have a workbook which has a number of sheets, 4 of which when I click a button I'm trying to export to a new workbook.
As well as this, I'm trying to copy a module I've got titled as "Schuco" to the new workbook.

The code I'm using is as follows:


Sub ExportSchucoDocument()
Application.ScreenUpdating = False
If MsgBox("An Excel copy will be generated and you'll be notified to save.", vbYesNo) = vbNo Then Exit Sub
Const MODULE_NAME As String = "Schuco"
Const TEMPFILE As String = "C:\Schuco.bas"
ThisWorkbook.VBProject.VBComponents(MODULE_NAME).Export TEMPFILE
Sheets("Schuco Price List").Visible = xlSheetVisible
Sheets("Schuco Rate Sheet").Visible = xlSheetVisible
Sheets("Schuco Schedule").Visible = xlSheetVisible
Sheets(Array("Schuco Front Sheet", "Schuco Schedule", "Schuco Price List", _
"Schuco Rate Sheet")).Select
Sheets("Schuco Rate Sheet").Activate
Sheets(Array("Schuco Front Sheet", "Schuco Schedule", "Schuco Price List", _
"Schuco Rate Sheet")).Copy
WBK.VBProject.VBComponents.Import TEMPFILE
Kill TEMPFILE
Application.Dialogs(xlDialogSaveAs).Show
MsgBox "Copy saved. The copy will now close." _
& vbCrLf _
& myFile
ActiveWorkbook.Close
Sheets("Schuco Price List").Visible = xlSheetVeryHidden
Sheets("Schuco Rate Sheet").Visible = xlSheetVeryHidden
Sheets("Schuco Schedule").Visible = xlSheetVeryHidden
Application.ScreenUpdating = True
End Sub


First of all, I'm not 100% sure I've even got this right.
Secondly, when running the code I get the following error message:

Run-time error '50035'
Method 'Export' of object '_VBComponent' failed

When I debug, it highlights the following line of code:


ThisWorkbook.VBProject.VBComponents(MODULE_NAME).Export TEMPFILE

Any advice where I'm going wrong would be greatly appreciated.
Thank you.
Regards
Martin

Paul_Hossler
10-26-2017, 05:34 AM
Try exporting to somewhere other that C: root



Const TEMPFILE As String = "C:\Users\Martin\My Documents\Schuco.bas"

Marhier
10-26-2017, 07:57 AM
Hi Paul.
Thank you so much, that seems to have done the trick!
I also had an error with the following code:


WBK.VBProject.VBComponents.Import TEMPFILE


I sorted that by changing it to:


ActiveWorkbook.VBProject.VBComponents.Import TEMPFILE


My code is now as follows and works:


Sub ExportSchucoDocument()
Application.ScreenUpdating = False
If MsgBox("An Excel copy will be generated and you'll be notified to save.", vbYesNo) = vbNo Then Exit Sub
Const MODULE_NAME As String = "Schuco"
C:\Users\" & Environ("username") & "\Documents\Schuco.bas"
ThisWorkbook.VBProject.VBComponents(MODULE_NAME).Export TEMPFILE
Sheets("Schuco Price List").Visible = xlSheetVisible
Sheets("Schuco Rate Sheet").Visible = xlSheetVisible
Sheets("Schuco Schedule").Visible = xlSheetVisible
Sheets(Array("Schuco Front Sheet", "Schuco Schedule", "Schuco Price List", _
"Schuco Rate Sheet")).Select
Sheets("Schuco Rate Sheet").Activate
Sheets(Array("Schuco Front Sheet", "Schuco Schedule", "Schuco Price List", _
"Schuco Rate Sheet")).Copy
ActiveWorkbook.VBProject.VBComponents.Import TEMPFILE
Kill TEMPFILE
Application.Dialogs(xlDialogSaveAs).Show
MsgBox "Copy saved. The copy will now close." _
& vbCrLf _
& myFile
ActiveWorkbook.Close
Sheets("Schuco Price List").Visible = xlSheetVeryHidden
Sheets("Schuco Rate Sheet").Visible = xlSheetVeryHidden
Sheets("Schuco Schedule").Visible = xlSheetVeryHidden
Application.ScreenUpdating = True
End Sub


My next question is, because this is going to be used by multiple users, how do I change the following code so that it goes to any user's 'Documents' folder?


C:\Users\" & Environ("username") & "\Documents\Schuco.bas"

Really appreciate your help.
Regards
Martin

snb
10-26-2017, 08:56 AM
I'd copy the whole workbook and would delete all modules that are not required.

Marhier
10-26-2017, 09:14 AM
I'd copy the whole workbook and would delete all modules that are not required.

This is a rather large document with 50+ worksheets in.
I'm only looking to extract 4 of the sheets and the corresponding VBA Module related to that supplier.

The code above works perfectly; I'm just after how to get the following to work now:


"C:\Users\" & Environ("username") & "\Documents\Schuco.bas"

I'm assuming I have to set this as a variable somewhere, but not sure how to do this.

Any advice would be appreciated.

Thank you.
Regards
Martin

Paul_Hossler
10-26-2017, 10:29 AM
Option Explicit
Sub MyDocs()
Const sf_DOCUMENTS As Long = 5

Dim MyDocsFolder As String
MyDocsFolder = CreateObject("Shell.Application").Namespace(CVar(sf_DOCUMENTS)).Self.Path
MsgBox MyDocsFolder
End Sub

snb
10-26-2017, 01:22 PM
Why don't you keep the macros for that supplier in one of the worksheets you want to copy ?

Marhier
10-26-2017, 11:46 PM
Option Explicit
Sub MyDocs()
Const sf_DOCUMENTS As Long = 5

Dim MyDocsFolder As String
MyDocsFolder = CreateObject("Shell.Application").Namespace(CVar(sf_DOCUMENTS)).Self.Path
MsgBox MyDocsFolder
End Sub



Thank you Paul, though how do I incorporate this into my code for it to work?



Why don't you keep the macros for that supplier in one of the worksheets you want to copy ?

I tried this, but as my code deals with a lot of x1SheetVeryHidden, every time a button is clicked, I get a 'VBA Error: 400:
Even though I get this error, the code runs fine, just that box pops up every time and it's annoying.

Unless you know how I stop it doing that?

I appreciate all your support.
Thank you.
Regards
Martin

snb
10-27-2017, 12:36 AM
How can I guesss not seeing your code ??

Marhier
10-27-2017, 12:44 AM
The Subs giving me the 400 error are as follows.
You'll see most of it is just page request and hides and clear functions.

Enjoy, lol


Sub ClearSchucoFrontSheet()
If MsgBox("This will erase everything! Are you sure?", vbYesNo) = vbNo Then Exit Sub
Application.ScreenUpdating = False
Application.Goto Reference:="Schuco_Front_Sheet_Text"
Selection.ClearContents
ActiveWindow.ScrollRow = 1
Range("I13").Select
Application.ScreenUpdating = True
End Sub

Sub RequestSchucoPriceList()
Application.ScreenUpdating = False
Sheets("Schuco Price List").Visible = xlSheetVisible
ActiveSheet.Visible = xlSheetVeryHidden
ActiveWindow.ScrollRow = 1
Range("A1").Select
Application.ScreenUpdating = True
End Sub

Sub RequestSchucoSchedule()
Application.ScreenUpdating = False
Sheets("Schuco Schedule").Visible = xlSheetVisible
ActiveSheet.Visible = xlSheetVeryHidden
ActiveWindow.ScrollRow = 1
Range("A1").Select
SchucoSchedule.Activate
ActiveWindow.Zoom = 67
Application.ScreenUpdating = True
End Sub

Sub RequestSchucoFrontSheet()
Application.ScreenUpdating = False
Sheets("Schuco Front Sheet").Visible = xlSheetVisible
ActiveSheet.Visible = xlSheetVeryHidden
ActiveWindow.ScrollRow = 1
Range("I13").Select
Application.ScreenUpdating = True
End Sub

Sub RequestSchucoRateSheet()
Application.ScreenUpdating = False
Sheets("Schuco Rate Sheet").Visible = xlSheetVisible
ActiveSheet.Visible = xlSheetVeryHidden
ActiveWindow.ScrollRow = 1
Range("A1").Select
Application.ScreenUpdating = True
End Sub

Sub ClearPartSchucoScheduleText()
If MsgBox("This will erase all material items, but keep the project headings! Are you sure?", vbYesNo) = vbNo Then Exit Sub
Application.ScreenUpdating = False
Application.Goto Reference:="Schuco_Schedule_Text_Part"
Selection.ClearContents
ActiveWindow.ScrollRow = 1
Range("A1:G7").Select
Application.ScreenUpdating = True
End Sub

Sub ClearAllSchucoScheduleText()
If MsgBox("This will erase everything! Are you sure?", vbYesNo) = vbNo Then Exit Sub
Application.ScreenUpdating = False
Application.Goto Reference:="Schuco_Schedule_Text_All"
Selection.ClearContents
ActiveWindow.ScrollRow = 1
Range("A1:G7").Select
Application.ScreenUpdating = True
End Sub

Sub AddRowtoSchucoSchedule()
Application.ScreenUpdating = False
ActiveSheet.Unprotect ("PRA0809")
Dim Lr As Integer
Lr = Range("A" & Rows.Count).End(xlUp).Row 'Searching last row in column A
Rows(Lr + 1).Insert Shift:=xlDown 'Inserting new row
Rows(Lr).Copy 'Copying format of last row
Rows(Lr + 1).PasteSpecial Paste:=xlPasteFormats 'Pasting format to new row
Rows(Lr + 1).PasteSpecial Paste:=xlPasteFormulas 'Pasting formulas to new row
Application.CutCopyMode = False 'Deactivating copy mode
Cells(Lr + 1, "A") = Cells(Lr, "A") + 1 'Adding a sequential number
Range("A1:G7").Select 'Selects the top left cells
ActiveSheet.Protect Password:="PRA0809", DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
End Sub


Appreciate your help mate, really do.
Regards
Martin

snb
10-27-2017, 01:11 AM
You' d better improve the code before copying:
Avoid 'select', 'activate' and application.goto in VBA
Why hiding/unhiding unnecessarily ?


Sub ClearSchucoFrontSheet()
If MsgBox("This will erase everything! Are you sure?", vbYesNo)=vbYes then sheets("Schuco_Front_Sheet_Text").cells.clearcontents
End Sub

Sub RequestSchucoPriceList()
with Sheets("Schuco Price List")
.Visible = -1
.activate
end with
End Sub

Marhier
10-27-2017, 01:59 AM
Thank you.
I've tried what you've suggested and am always interested to learn how to simplify code.

Reducing the following code is giving me a Run-time error '9': - Subscript out of range:


Sub ClearSchucoFrontSheet()
If MsgBox("This will erase everything! Are you sure?", vbYesNo) = vbYes Then Sheets("Schuco_Front_Sheet_Text").Cells.ClearContents
End Sub


Your suggestion on the requests of other sheets works fine, but doesn't hide the sheets completely.
The document I've created is going to be used by a number people and I don't want them to have the ability to unhide sheets (as there are 50+ sheets), or do much of anything other than use the functions I've provided.
It seems unnecessary, but for my intended application, I would prefer to leave it as keeping sheets very hidden.

How do I amend the following code to completely hide the sheet I'm leaving?


Sub RequestSchucoPriceList()
With Sheets("Schuco Price List")
.Visible = -1
.Activate
End With
End Sub

Jan Karel Pieterse
10-27-2017, 02:41 AM
Replace the -1 with the more legible built-in constant that belongs to the Visible property: xlSheetVeryHidden

snb
10-27-2017, 03:02 AM
In that case:
Sheets("Schuco_Front_Sheet_Text") is lacking.


Sub RequestSchucoPriceList()
With Sheets("Schuco Price List")
.Visible = -1
.Activate
End With
Activesheet.visible=2
End Sub

Marhier
10-27-2017, 03:08 AM
Thank you.

snb
10-27-2017, 03:28 AM
I already told you: the sheet doesn't exist in the activeworkbook (you didn't copy it).

Marhier
10-27-2017, 03:49 AM
I'm struggling to understand what you mean, or understand how you've amended my code... The code you amended for me to clear the text in a named range I've set isn't working.
I'm also getting '400' errors on my AddARow and a number of other subs...
I appreciate the support, but feel it is becoming quite fiddly and was wondering if you could provide an answer to my original query in getting the following to work:


Sub ExportSchucoDocument()
Application.ScreenUpdating = False
If MsgBox("An Excel copy will be generated and you'll be notified to save.", vbYesNo) = vbNo Then Exit Sub
Const MODULE_NAME As String = "Schuco"
Const TEMPFILE As String = "C:\Users\" & Environ("username") & "\Documents\Schuco.bas"
ThisWorkbook.VBProject.VBComponents(MODULE_NAME).Export TEMPFILE
Sheets("Schuco Price List").Visible = xlSheetVisible
Sheets("Schuco Rate Sheet").Visible = xlSheetVisible
Sheets("Schuco Schedule").Visible = xlSheetVisible
Sheets(Array("Schuco Front Sheet", "Schuco Schedule", "Schuco Price List", _
"Schuco Rate Sheet")).Select
Sheets("Schuco Rate Sheet").Activate
Sheets(Array("Schuco Front Sheet", "Schuco Schedule", "Schuco Price List", _
"Schuco Rate Sheet")).Copy
ActiveWorkbook.VBProject.VBComponents.Import TEMPFILE
Kill TEMPFILE
MsgBox "Copy saved. The copy will now close." _
& vbCrLf _
& myFile
ActiveWorkbook.Close
Sheets("Schuco Price List").Visible = xlSheetVeryHidden
Sheets("Schuco Rate Sheet").Visible = xlSheetVeryHidden
Sheets("Schuco Schedule").Visible = xlSheetVeryHidden
Application.ScreenUpdating = True
End Sub


As I understand it, I would need to declare it as a variable

Dim strTempFile As String

Then assign it my variable

strTempFile = "C:\Users\" & Environ("username") & "\Documents\Schuco.bas"


I've tried amending my code as follows:

Sub ExportSchucoDocument()
Dim strTempFile As String
Application.ScreenUpdating = False
If MsgBox("An Excel copy will be generated and you'll be notified to save.", vbYesNo) = vbNo Then Exit Sub
Const MODULE_NAME As String = "Schuco"
strTempFile = "C:\Users\" & Environ("username") & "\Documents\Schuco.bas"
ThisWorkbook.VBProject.VBComponents(MODULE_NAME).Export TEMPFILE
Sheets("Schuco Price List").Visible = xlSheetVisible
Sheets("Schuco Rate Sheet").Visible = xlSheetVisible
Sheets("Schuco Schedule").Visible = xlSheetVisible
Sheets(Array("Schuco Front Sheet", "Schuco Schedule", "Schuco Price List", _
"Schuco Rate Sheet")).Select
Sheets("Schuco Rate Sheet").Activate
Sheets(Array("Schuco Front Sheet", "Schuco Schedule", "Schuco Price List", _
"Schuco Rate Sheet")).Copy
ActiveWorkbook.VBProject.VBComponents.Import TEMPFILE
Kill TEMPFILE
Application.Dialogs(xlDialogSaveAs).Show
MsgBox "Copy saved. The copy will now close." _
& vbCrLf _
& myFile
ActiveWorkbook.Close
Sheets("Schuco Price List").Visible = xlSheetVeryHidden
Sheets("Schuco Rate Sheet").Visible = xlSheetVeryHidden
Sheets("Schuco Schedule").Visible = xlSheetVeryHidden
Application.ScreenUpdating = True
End Sub

But when testing, I'm getting the message:

Run-time error '50035'
Method 'Export' of object '_VBComponent' failed


Appreciate all the support you've shown.
Regards
Martin

greyangel
10-27-2017, 05:25 AM
This is a rather large document with 50+ worksheets in.
I'm only looking to extract 4 of the sheets and the corresponding VBA Module related to that supplier.

The code above works perfectly; I'm just after how to get the following to work now:


"C:\Users\" & Environ("username") & "\Documents\Schuco.bas"

I'm assuming I have to set this as a variable somewhere, but not sure how to do this.

Any advice would be appreciated.

Thank you.
Regards
Martin


Would this work for you?


ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Sheets(1).Name, FileFormat:=50


Here the different fileformats and what they mean the current number in the fileformat is 50(Xl binary):
51 = xlOpenXMLWorkbook (without macro's in 2007-2016, xlsx)
52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2016, xlsm)
50 = xlExcel12 (Excel Binary Workbook in 2007-2016 with or without macro's, xlsb)
56 = xlExcel8 (97-2003 format in Excel 2007-2016, xls)

Paul_Hossler
10-27-2017, 05:42 AM
Thank you Paul, though how do I incorporate this into my code for it to work?




TEMPFILE = CreateObject("Shell.Application").Namespace(CVar(sf_DOCUMENTS)).Self.Path & "\Schuco.bas"

snb
10-27-2017, 06:39 AM
Sub M_snb()
ThisWorkbook.SaveCopyAs "G:\OF\example.xlsb"

With GetObject("G:\OF\example.xlsb")
For Each it In .Sheets
If InStr("Schuco Front Sheet_Schuco Schedule_Schuco Price List_Schuco Rate Sheet", it.Name) = 0 Then it.Delete
Next

For Each it In ThisWorkbook.VBProject.vbcomponents
If it.Type = 1 Then If it.Name <> "Schuco" Then ThisWorkbook.VBProject.vbcomponents.Remove it
Next
.Application.Visible = -1
.Close -1
End With
End Sub

Marhier
10-27-2017, 06:46 AM
Thanks Paul, that works a treat.
I'm about to do a complete 180 here though, as I've realised I need to go back to what user snb suggested in moving my code over to one of the worksheets I'm copying and not by exporting a module.
The reason behind this is because the VBA project is locked and password protected, even with a VBA in there to unlock it when clicking a button (which I've tried), if another user's settings aren't specifically set to trust VBA, the code just doesn't run.

I only have issues with two bits of code now - I managed to make everything else work with what user snb has helped me with (and I thank you for that).
The following lines of code are returning a '400' error:

This first one is just to insert a row at the bottom of the table on the worksheet called 'Schuco Schedule:


Sub AddRowtoSchucoSchedule()
Application.ScreenUpdating = False
ActiveSheet.Unprotect ("PRA0809")
Dim Lr As Integer
Lr = Range("A" & Rows.Count).End(xlUp).Row 'Searching last row in column A
Rows(Lr + 1).Insert Shift:=xlDown 'Inserting new row
Rows(Lr).Copy 'Copying format of last row
Rows(Lr + 1).PasteSpecial Paste:=xlPasteFormats 'Pasting format to new row
Rows(Lr + 1).PasteSpecial Paste:=xlPasteFormulas 'Pasting formulas to new row
Application.CutCopyMode = False 'Deactivating copy mode
Cells(Lr + 1, "A") = Cells(Lr, "A") + 1 'Adding a sequential number
Application.Goto Sheets("Schuco Schedule").Cells(1, 1) 'Selects the top left cells
ActiveSheet.Protect Password:="PRA0809", DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
End Sub


The next bit of code takes a copy of the worksheet "Schuco Schedule" and exports just that sheet in a separate document.
The code seems to be failing once it gets to the section where I ask it to name the sheet in new workbook to what cell P4 is.


Sub ExportSchucoScheduletoXls()
Application.ScreenUpdating = False
If Worksheets("Schuco Schedule").Range("$P$1").Value = "" Then
MsgBox "Please enter a schedule number."
Exit Sub
End If
If MsgBox("An Excel copy will be generated and you'll be notified to save.", vbYesNo) = vbNo Then Exit Sub
ActiveSheet.Unprotect ("PRA0809")
Sheets("Schuco Schedule").Select
Sheets("Schuco Schedule").Copy
ActiveSheet.Shapes.Range(Array("SchucoHomeButton")).Delete
ActiveSheet.Shapes.Range(Array("SchucoExportButton")).Delete
ActiveSheet.Shapes.Range(Array("SchucoAddRowButton")).Delete
ActiveSheet.Shapes.Range(Array("SchucoPriceListButton")).Delete
ActiveSheet.Shapes.Range(Array("SchucoFrontSheetButton")).Delete
ActiveSheet.Shapes.Range(Array("SchucoRateSheetButton")).Delete
ActiveSheet.Shapes.Range(Array("SchucoClearPartButton")).Delete
ActiveSheet.Shapes.Range(Array("SchucoClearAllButton")).Delete
Application.Goto Reference:="Schuco_VLookUp_Text_1"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Goto Reference:="Schuco_VLookUp_Text_2"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Goto Reference:="Schuco_VLookUp_Text_3"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Goto Reference:="Schuco_VLookUp_Text_4"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Goto Reference:="Schuco_VLookUp_Text_5"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Goto Reference:="Schuco_VLookUp_Text_6"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Goto Reference:="Schuco_VLookUp_Text_7"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Goto Reference:="Schuco_VLookUp_Text_8"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Dim ws As Worksheet
For Each ws In Worksheets
ws.Activate
ws.Name = Range("$P$1").Value
Next
Dim xName As Name
On Error Resume Next
For Each xName In ActiveWorkbook.Names
xName.Delete
Next
Application.Dialogs(xlDialogSaveAs).Show
MsgBox "Copy saved. The copy will now close." _
& vbCrLf _
& myFile
ActiveWorkbook.Close
Application.Goto Sheets("Schuco Schedule").Cells(1, 1)
ActiveSheet.Protect Password:="PRA0809", DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
End Sub


I understand it's got something to do with how my code is calling for named sheets it can't find, but I'm really struggling to put it right and can't figure out how to make it work.

Any guidance is appreciated.
Thank you.
Martin

snb
10-27-2017, 07:22 AM
All you need:

http://www.vbaexpress.com/forum/showthread.php?61146-Copy-Module-to-New-Workbook&p=371882&viewfull=1#post371882

Marhier
10-27-2017, 07:44 AM
That just gives me a '400' error as well.
Please be mindful that my vba knowledge is very limited and I'm only good at making code that I've learned via recording macros and the advice of other users.

Allow me to give you context to the document I've made.
It is a master document which holds price lists for all the suppliers I deal with.
Every supplier has a front sheet where you can enquire prices via drop down boxes.
There is also a scheduling tool for other departments to use where they can issue a standalone schedule by exporting the page their on and issue to another department for ordering.

With this Schuco section of the document, I need it to work as is, when the document isn't being exported by anyone...
The issues I've mentioned above need to work

All I need to know if how to get the following codes to stop giving me a '400' error... Then all my problems will be solved.

Note: These codes worked perfectly find when they were in a module... It's only since moving them to the worksheet that it's stopped working


This first one is just to insert a row at the bottom of the table on the worksheet called 'Schuco Schedule:


Sub AddRowtoSchucoSchedule()
Application.ScreenUpdating = False
ActiveSheet.Unprotect ("PRA0809")
Dim Lr As Integer
Lr = Range("A" & Rows.Count).End(xlUp).Row 'Searching last row in column A
Rows(Lr + 1).Insert Shift:=xlDown 'Inserting new row
Rows(Lr).Copy 'Copying format of last row
Rows(Lr + 1).PasteSpecial Paste:=xlPasteFormats 'Pasting format to new row
Rows(Lr + 1).PasteSpecial Paste:=xlPasteFormulas 'Pasting formulas to new row
Application.CutCopyMode = False 'Deactivating copy mode
Cells(Lr + 1, "A") = Cells(Lr, "A") + 1 'Adding a sequential number
Application.Goto Sheets("Schuco Schedule").Cells(1, 1) 'Selects the top left cells
ActiveSheet.Protect Password:="PRA0809", DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
End Sub


The next bit of code takes a copy of the worksheet "Schuco Schedule" and exports just that sheet in a separate document.
The code seems to be failing once it gets to the section where I ask it to name the sheet in new workbook to what cell P1 is.


Sub ExportSchucoScheduletoXls()
Application.ScreenUpdating = False
If Worksheets("Schuco Schedule").Range("$P$1").Value = "" Then
MsgBox "Please enter a schedule number."
Exit Sub
End If
If MsgBox("An Excel copy will be generated and you'll be notified to save.", vbYesNo) = vbNo Then Exit Sub
ActiveSheet.Unprotect ("PRA0809")
Sheets("Schuco Schedule").Select
Sheets("Schuco Schedule").Copy
ActiveSheet.Shapes.Range(Array("SchucoHomeButton")).Delete
ActiveSheet.Shapes.Range(Array("SchucoExportButton")).Delete
ActiveSheet.Shapes.Range(Array("SchucoAddRowButton")).Delete
ActiveSheet.Shapes.Range(Array("SchucoPriceListButton")).Delete
ActiveSheet.Shapes.Range(Array("SchucoFrontSheetButton")).Delete
ActiveSheet.Shapes.Range(Array("SchucoRateSheetButton")).Delete
ActiveSheet.Shapes.Range(Array("SchucoClearPartButton")).Delete
ActiveSheet.Shapes.Range(Array("SchucoClearAllButton")).Delete
Application.Goto Reference:="Schuco_VLookUp_Text_1"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Goto Reference:="Schuco_VLookUp_Text_2"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Goto Reference:="Schuco_VLookUp_Text_3"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Goto Reference:="Schuco_VLookUp_Text_4"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Goto Reference:="Schuco_VLookUp_Text_5"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Goto Reference:="Schuco_VLookUp_Text_6"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Goto Reference:="Schuco_VLookUp_Text_7"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Goto Reference:="Schuco_VLookUp_Text_8"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Dim ws As Worksheet
For Each ws In Worksheets
ws.Activate
ws.Name = Range("$P$1").Value
Next
Dim xName As Name
On Error Resume Next
For Each xName In ActiveWorkbook.Names
xName.Delete
Next
Application.Dialogs(xlDialogSaveAs).Show
MsgBox "Copy saved. The copy will now close." _
& vbCrLf _
& myFile
ActiveWorkbook.Close
Application.Goto Sheets("Schuco Schedule").Cells(1, 1)
ActiveSheet.Protect Password:="PRA0809", DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
End Sub

Marhier
10-27-2017, 02:21 PM
OK, I've solved the issue I was having with Export code.

The issue lied with the following:


Dim ws As Worksheet
For Each ws In Worksheets
ws.Activate
ws.Name = Range("$P$1").Value
Next
Dim xName As Name
On Error Resume Next
For Each xName In ActiveWorkbook.Names
xName.Delete
Next


I changed it to:

Dim xWs As Worksheet
Dim xRngAddress As String
Dim xName As String
xRngAddress = Range("$P$1").Address
For Each xWs In Application.ActiveWorkbook.Sheets
xName = xWs.Range(xRngAddress).Value
If xName <> "" Then
xWs.Name = xName
End If
Next


So the only issue I'm having now is with the following:

Sub AddRowtoSchucoSchedule()
Dim Lr As Integer
On Error GoTo Errorcatch
Application.ScreenUpdating = False
ActiveSheet.Unprotect ("PRA0809")
Lr = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row 'Searching last row in column A
Rows(Lr + 1).Insert Shift:=xlDown 'Inserting new row
Rows(Lr).Copy 'Copying format of last row
Rows(Lr + 1).PasteSpecial Paste:=xlPasteFormats 'Pasting format to new row
Rows(Lr + 1).PasteSpecial Paste:=xlPasteFormulas 'Pasting formulas to new row
Application.CutCopyMode = False 'Deactivating copy mode
Cells(Lr + 1, "A") = Cells(Lr, "A") + 1 'Adding a sequential number
Application.Goto Sheets("Schuco Schedule").Cells(1, 1) 'Selects the top left cells
ActiveSheet.Protect Password:="PRA0809", DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
Exit Sub
Errorcatch:
MsgBox Err.Description
End Sub

The error handler shows the message:
Insert Method of Range Class Failed

Thank you.
Martin

Tom Jones
10-29-2017, 01:49 PM
Cross post with lot of answers....

https://www.mrexcel.com/forum/excel-questions/1028727-copy-module-new-workbook.html

Marhier
10-29-2017, 11:33 PM
Appreciate that Tom and apologies for not posting the link to the cross post.
There's a lot of answers, yes... But the final problem I've got is trying to get the following bit of code to work.
Having this in a module works absolutely fine, but due to me needing to have the code within the worksheet, it's giving me a '400' error; with an error catcher added to the code, it displays the message:
'Insert Method of Range Class Failed'

From all the advice I've had so far, I can see it has something to do with what sheet is selected?
I've tried a number of ways, including what's already been suggested to get the sheet selected and nothing I try seems to work.

As before, the code is as follows:

Sub AddRowstoSchedule()
With Sheets("Schuco Schedule")
.Select
Application.ScreenUpdating = False
ActiveSheet.Unprotect ("PRA0809")
Dim Lr As Integer
Lr = Range("A" & Rows.Count).End(xlUp).Row 'Searching last row in column A
Rows(Lr + 1).Insert Shift:=xlDown 'Inserting new row
Rows(Lr).Copy 'Copying format of last row
Rows(Lr + 1).PasteSpecial Paste:=xlPasteFormats 'Pasting format to new row
Rows(Lr + 1).PasteSpecial Paste:=xlPasteFormulas 'Pasting formulas to new row
Application.CutCopyMode = False 'Deactivating copy mode
Cells(Lr + 1, "A") = Cells(Lr, "A") + 1 'Adding a sequential number
Range("A1").Select 'Selects the top left cells
ActiveSheet.Protect Password:="PRA0809", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True
Application.ScreenUpdating = True
End With
End Sub

This is the final bit of code I need to work on a document that's taken me 4 months to build and would really appreciate any help on solving this issue.
Thank you.
Regards
Martin

Marhier
10-30-2017, 05:26 AM
Please note that this thread has been solved.


Sub AddRowstoSchedule()
Application.ScreenUpdating = False
With Sheets("Schuco Schedule")
.Unprotect ("UNLOCK*")
Dim Lr As Integer
Lr = .Range("A" & .Rows.Count).End(xlUp).Row 'Searching last row in column A
.Rows(Lr + 1).Insert Shift:=xlDown 'Inserting new row
.Rows(Lr).Copy 'Copying format of last row
.Rows(Lr + 1).PasteSpecial Paste:=xlPasteFormats 'Pasting format to new row
.Rows(Lr + 1).PasteSpecial Paste:=xlPasteFormulas 'Pasting formulas to new row
Application.CutCopyMode = False 'Deactivating copy mode
.Cells(Lr + 1, "A") = .Cells(Lr, "A") + 1 'Adding a sequential number
.Protect Password:="UNLOCK*", DrawingObjects:=True, Contents:=True, _
Scenarios:=True, AllowFormattingCells:=True
End With
Application.ScreenUpdating = True
End Sub

Credit to User:
Rory

Solved at:
https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/1194584-insert-method-of-range-class-failed