Copy Module to New Workbook

[Marhier]

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]

Try exporting to somewhere other that C: root

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

[Marhier]

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]

I'd copy the whole workbook and would delete all modules that are not required.

[Marhier]

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]

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]

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

[Marhier]

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]

How can I guesss not seeing your code ??

[Marhier]

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]

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]

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]

Replace the -1 with the more legible built-in constant that belongs to the Visible property: xlSheetVeryHidden

[snb]

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]

Thank you.

[snb]

I already told you: the sheet doesn't exist in the activeworkbook (you didn't copy it).

[Marhier]

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]

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]

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]

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