Save worksheet as new macro-enabled Workbook

[tlc53]

Hi,

I nearly have this working. I want sheet 12 (called Journal) to be copied and saved into a new macro-enabled workbook. It's getting stuck at the save part, saying "The following features cannot be saved in macro-free workbooks: VB project"

Sub New_Journal()
     Dim wb As Workbook
    Set wb = Workbooks.Add
    ThisWorkbook.Sheets("Journal").Copy Before:=wb.Sheets(1)
    wb.SaveAs "C:\Users\Andrew\Documents\JournalNEW.xlsm"
End Sub

Can someone please tell me where I am going wrong? Thanks!

 

[DanteAmor]

Try this

Hi,

I nearly have this working. I want sheet 12 (called Journal) to be copied and saved into a new macro-enabled workbook. It's getting stuck at the save part, saying "The following features cannot be saved in macro-free workbooks: VB project"

Sub New_Journal()
     Dim wb As Workbook
    Set wb = Workbooks.Add
    ThisWorkbook.Sheets("Journal").Copy Before:=wb.Sheets(1)
    wb.SaveAs "C:\Users\Andrew\Documents\JournalNEW.xlsm"[COLOR=#ff0000], FileFormat:=xlOpenXMLWorkbookMacroEnabled[/COLOR]
End Sub

Can someone please tell me where I am going wrong? Thanks!

 

[tlc53]

Thanks Dante! That fixed the problem.

I have been compiling my VBA macro but there's a couple of things that aren't working correctly.

Firstly, when it moves the "Journal" tab over onto a new sheet, I then ask that it deletes "Sheet1" from the newly created workbook. However, it asks for manual confirmation (Are you sure you want to delete Sheet1). How can I amend the code to say yes, delete the sheet.

Secondly, when the new "Journals" tab is created, there's 4x user macro buttons. However, the macro buttons refer to the original "E3 Sheet" instead of running the macros based on the data in the new "Journals" spreadsheet. You will see I tried re-assigning the macro's to the buttons but this doesn't appear to have worked.

Lastly, instead of writing the file name save and locations (wb.SaveAs "C:\Users\Andrew\Documents\Journals YE 31 May 2019.xlsm") how can I amend this to refer to the file name and location stated in cell K1 (which is formulated)?

Really appreciate your help. Thanks!

Sub E3_Journal_1_New()
'
' E3_Journal_1_New Macro
'


'
    Sheets("E3").Select
    Sheets("Journal").Visible = True
    Sheets("Journal").Select
    Range("C6:E7").Select
    Selection.Copy
    Range("C6:E6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C8").Select
    Application.CutCopyMode = False
    Sheets("E3").Select
    ActiveWindow.SmallScroll Down:=27
    Rows("48:61").Select
    Selection.EntireRow.Hidden = False
    Range("A36:M46").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll Down:=12
    Range("A49").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.SmallScroll Down:=-6
    Range("B37:B46").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Range("E37:J46").Select
    Selection.ClearContents
    Range("M37:M46").Select
    Selection.ClearContents
    Rows("50:59").Select
    Selection.Copy
    Sheets("Journal").Select
    Rows("12:12").Select
    Selection.Insert Shift:=xlDown
    Range("A12:N21").Select
    Application.CutCopyMode = False
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
    Range("N12:N21").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Range("A12").Select
    Dim wb As Workbook
    Set wb = Workbooks.Add
    ThisWorkbook.Sheets("Journal").Copy Before:=wb.Sheets(1)
    wb.SaveAs "C:\Users\Andrew\Documents\Journals YE 31 May 2019.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
    
    Windows("Journals YE 31 May 2019.xlsm").Activate
    ActiveSheet.Shapes.Range(Array("Button 4")).Select
    Selection.OnAction = "Sheet12.Delete_Blank_Rows"
    ActiveSheet.Shapes.Range(Array("Button 2")).Select
    Selection.OnAction = "Sheet12.ResetFilters"
    ActiveSheet.Shapes.Range(Array("Button 3")).Select
    Selection.OnAction = "Sheet12.Unposted_Journals"
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Selection.OnAction = "Sheet12.Search_For_Date"
    Sheets("Sheet1").Select
    ActiveWindow.SelectedSheets.Delete
    Range("A12").Select
    ActiveWindow.SmallScroll Down:=-15
    ActiveWorkbook.Save
    ActiveWindow.Close
    Sheets("Journal").Select
    ActiveWindow.SelectedSheets.Visible = False
    Sheets("E3").Select
    Range("A49:M60").Select
    Selection.Locked = True
    ActiveWindow.SmallScroll Down:=-12
    Range("B37").Select
End Sub

 

[DanteAmor]

Change this

    Dim wb As Workbook
    Set wb = Workbooks.Add
    ThisWorkbook.Sheets("Journal").Copy Before:=wb.Sheets(1)
    wb.SaveAs "C:\Users\Andrew\Documents\Journals YE 31 May 2019.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
    
    Windows("Journals YE 31 May 2019.xlsm").Activate
    ActiveSheet.Shapes.Range(Array("Button 4")).Select
    Selection.OnAction = "Sheet12.Delete_Blank_Rows"
    ActiveSheet.Shapes.Range(Array("Button 2")).Select
    Selection.OnAction = "Sheet12.ResetFilters"
    ActiveSheet.Shapes.Range(Array("Button 3")).Select
    Selection.OnAction = "Sheet12.Unposted_Journals"
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Selection.OnAction = "Sheet12.Search_For_Date"
    Sheets("Sheet1").Select
    ActiveWindow.SelectedSheets.Delete
    Range("A12").Select
    ActiveWindow.SmallScroll Down:=-15
    ActiveWorkbook.Save
    ActiveWindow.Close
    Sheets("Journal").Select
    ActiveWindow.SelectedSheets.Visible = False

by this:

    Application.DisplayAlerts = False
    Application.SheetsInNewWorkbook = 1
    Dim wb As Workbook
    Dim wName As String
    wName = Sheets("Journal").Range("K1").Value
    ThisWorkbook.Sheets("Journal").Copy
    Set wb = ActiveWorkbook
    wb.SaveAs wName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    wb.Close False
    
    Sheets("Journal").Visible = False
    Sheets("E3").Select
    Range("A49:M60").Locked = True

perform a test of the execution of the buttons on the new sheet. according to me they should run in the new book without problem.


in cell K1 you should have the path, the name of the file and the extension, something like this:

C:\Users\Andrew\Documents\Journals YE 31 May 2019.xlsm

 

[tlc53]

Thanks. Everything's working fine except the buttons. They still seem to be running on the "E3" Sheet instead of the new "Journal" sheet.
I tried locating the macros on Sheet 12 (Journal tab), I also tried under a Module and then I tried ThisWorkbook. Each time, the new file keeps referring to the "E3" sheet. I can also see it's doing this when I right click on the button, in the new Journal sheet, the marco assigned is "'E3 Other Income.xlsm'!Sheet12.Delete_Blank_Rows" for eg.
Also, if I have sheet E3 closed and click on one of the macro buttons in the new Journal sheet, it opens the E3 Workbook.

I'm running out of things to try. Here are the macro button codes..

Sub ResetFilters()
    On Error Resume Next
    ActiveSheet.ShowAllData
End Sub


Sub Search_For_Date()
'Modified 11/20/2018 12:29:04 AM  EST
Application.ScreenUpdating = False
Dim i As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "N").End(xlUp).row
For i = 12 To LastRow
    If Cells(i, "N") = "" Then Cells(i, "N").Value = Date
Next
Application.ScreenUpdating = True
End Sub




Sub Delete_Blank_Rows()


    Dim lngLastRow As Long
    Dim lngMyRow As Long
    Dim xlnCalcMethod As XlCalculation
    
    With Application
        .ScreenUpdating = False
        xlnCalcMethod = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    lngLastRow = Range("A:L").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
    
    'Work backwards through the rows from the last row found to Row 12.
    For lngMyRow = lngLastRow To 12 Step -1
        If Len(Range("F" & lngMyRow)) = 0 And Len(Range("G" & lngMyRow)) = 0 Then
            Rows(lngMyRow).EntireRow.Delete
        End If
    Next lngMyRow
    
    With Application
        .Calculation = xlnCalcMethod
        .ScreenUpdating = True
    End With
    End Sub


    
Sub Unposted_Journals()
    ActiveSheet.Range("Jnl_Range").AutoFilter Field:=14, Criteria1:="="
End Sub

 

[DanteAmor]

Thanks. Everything's working fine except the buttons. They still seem to be running on the "E3" Sheet instead of the new "Journal" sheet.
I tried locating the macros on Sheet 12 (Journal tab),

But if you are copying the "journal" sheet and the buttons are on the "journal" sheet, from the source the button code must be on the "journal" sheet.


Try this code in a new book only with the "journal" sheet and its buttons.

Sub Test
    Application.DisplayAlerts = False
    Application.SheetsInNewWorkbook = 1
    Dim wb As Workbook
    Dim wName As String
    wName = Sheets("Journal").Range("K1").Value
    ThisWorkbook.Sheets("Journal").Copy
    Set wb = ActiveWorkbook
    wb.SaveAs wName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    wb.Close False
End Sub

The buttons must be in the new book. And they must run the macros.
This time they do not have to refer to another sheet, since there was only one sheet.

 

[tlc53]

I created a "TESTJNL" worksheet. This contained the "Journal/Sheet 12" tab only. The macro buttons stayed here.
I deleted all other module coding and placed your code (above) into a new module. I then ran your test code.
It saved a file "Journals YE 31 May 2019.xlsm". I then opened this file to test the buttons. The buttons were then referring to spreadsheet "TESTJNL" and not the active worksheet "Journals YE 31 May 2019.xlsm".

I hope I have followed instructions correctly..

 

[DanteAmor]

You can upload your test book to the cloud, with a single sheet, with buttons, macro and button macros.

 

[tlc53]

Thanks Dante. I'm obviously doing something strange..

https://www.dropbox.com/s/9wybwytrtahcxcq/TESTJNL.xlsm?dl=0

 

[DanteAmor]

Thanks Dante. I'm obviously doing something strange..

https://www.dropbox.com/s/9wybwytrtahcxcq/TESTJNL.xlsm?dl=0

Perfect! I ran the macro, created the new book, with the "Journal" sheet.
I closed the book, opened the new book.
There are the 4 buttons "delete", "clear", "view", "transfer". And I was able to run each of them with their own macro on the Sheet12(Journal) of the new book.

Maybe it's a problem in your office version.

Try following


Try the following approach. Copy the entire book, that includes all the sheets and all the macro.
Then open the new book and delete all the sheets except the "Journal" sheet.

Sub Test2()
    Application.DisplayAlerts = False
    Application.SheetsInNewWorkbook = 1
    Dim wb As Workbook, sh As Worksheet
    Dim wName As String
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    wName = Sheets("Journal").Range("K1").Value
    
[COLOR=#0000ff]    ThisWorkbook.SaveCopyAs wName[/COLOR]
    
    Set wb = Workbooks.Open(wName)
    For Each sh In wb.Sheets
      If LCase(sh.Name) <> LCase("Journal") Then
        sh.Delete
      End If
    Next
    wb.Close True
End Sub