Workbook & File SaveCopyAs

D

dfolzenlogen

New Member
Joined
Oct 18, 2009
Messages
36
Hi,
I have a workbook that is being used as a template for data entry and then uses File SaveAsCopy and File SaveAs xlsx macros to concatenate the filename per file naming parameters set by management along with others macros that place the cursor at Cell A1 of each worksheet; create a Word footer and also Clears Data and resets the worksheet. The File SaveAsCopy is being used because the macros need to be available to the end user in the event edits are required. I've added the macros to a Custom Ribbon tab and also added then to the Quick Access Toolbar. Everything works fine EXCEPT that when the end user brings up a file to be edited and uses the macros from either the Custom Ribbon Tab or the Quick Access Toolbar, the Template workbook is opened and any macro operations are against the Template NOT the workbook to be edited. Stranger yet (or at least to me) is that if the end user go to View ==>Macros==>View macros and accesses the same macros, they run against the correct workbook. Obviously, some is missing here but I can't figure it out. The code is below. Any suggestions or help is appreciated.
Code: 
Attribute VB_Name = "modMain"
Public strLastPath As String


Option Explicit


'Resets workbook to defaults and clears data
Public Sub ResetWorkbook()
Attribute ResetWorkbook.VB_Description = "Clears all data from worksheet EXCEPT Analyst's initials"
Attribute ResetWorkbook.VB_ProcData.VB_Invoke_Func = "C\n14"
   
    Dim lngLastRow As Long
    Dim strYesNo As String


    'Prompt user to confirm workbook reset
    strYesNo = MsgBox("Are you sure you want to reset this workbook?", vbYesNo, "Reset")
    If strYesNo = vbYes Then
   
        'Transfer Worksheet
        With wsTransfer
        
            'Remove extra lines from From/To
            Call ClearSheet(Range(.Range("A18"), .Range("rngTotalInterestFrom").Offset(-1, 1)))
            Call ClearSheet(Range(.Range("A25"), .Range("rngTotalInterestTo").Offset(-1, 1)))
            Call DeleteExtraRows(.Range("A17"), 2)
            Call DeleteExtraRows(.Range("A24"), 2)
            
            'Set defaults
            .Range("rngTransferPropertyName").Value = "SEE EXHIBIT A"
            .Range("rngTransferWellNo").Value = "SEE EXHIBIT A"
            .Range("rngTransferConveyance").Value = "X"
            .Range("rngTransferEstate").Value = ""
            .Range("rngTransferOther").Value = ""
            .Range("rngTransferDate").Value = ""
            .Range("rngTransferTax").Value = ""
            .Range("rngTransferCase").Value = ""
            
            .Range("A17").Value = ""
            .Range("D17").Value = ""
            .Range("F17").Value = 1
            .Range("A24").Value = ""
            .Range("D24").Value = ""
            .Range("F24").Value = 1
            
            .Range("rngTransferYes").Value = "X"
            .Range("rngTransferEffProd").Value = "ALL"
            .Range("rngTransferNo").Value = ""
            .Range("C17").Value = "RY"
            .Range("C24").Value = "RY"
            
            'Clear other fields
            .Range("A17:B17,H17:I17,A24:B24,H24:J24,B28:J29,F35:F36").Value = ""
            
            'Reset colors if needed
            .Range("A17:D17,F17,H17:I17,A24:D24,F24,H24:J24").Interior.Color = 13434879
            
            'Restore formulas
            .Range("F19").FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
            .Range("F26").FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
        
        End With
        
        'Exhibit A Worksheet
        With wsExhibitA
        
            'Remove extra lines from From/To
            Call DeleteExtraRows(.Range("A3"), 2)
            Call DeleteExtraRows(.Range("A5"), 5)
            Call ClearSheet(.Range("B6:D9"))
            
            'Reset formulas
            .Range("B3").FormulaR1C1 = "=Transfer!R[14]C"
            .Range("B5").FormulaR1C1 = "=Transfer!R[19]C"
            .Range("C3").FormulaR1C1 = "=Transfer!R[14]C[-2]"
            .Range("D3").FormulaR1C1 = "=Transfer!R[14]C[2]"
            .Range("C5").FormulaR1C1 = "=Transfer!R[19]C[-2]"
            .Range("D5").FormulaR1C1 = "=Transfer!R[19]C[2]"
            
            'Clear data in main section
            Call ClearSheet(Range(.Range("A11"), .Range("rngExhibitComments").Offset(-2, 10)))
            
            'Remove extra rows from main section
            Call DeleteExtraRows(.Range("A24"), 1)
            
            'Add borders to bottom of data if needed
            With Range(.Range("rngExhibitComments").Offset(-2, 0), .Range("rngExhibitComments").Offset(-2, 10))
                .Borders(xlDiagonalDown).LineStyle = xlNone
                .Borders(xlDiagonalUp).LineStyle = xlNone
                .Borders(xlEdgeLeft).LineStyle = xlNone
                .Borders(xlEdgeTop).LineStyle = xlNone
                With .Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                .Borders(xlEdgeRight).LineStyle = xlNone
                .Borders(xlInsideVertical).LineStyle = xlNone
                .Borders(xlInsideHorizontal).LineStyle = xlNone
            End With
            
            With Range(.Range("rngExhibitComments").Offset(-1, 0), .Range("rngExhibitComments").Offset(-1, 10))
                .Borders(xlDiagonalDown).LineStyle = xlNone
                .Borders(xlDiagonalUp).LineStyle = xlNone
                .Borders(xlEdgeLeft).LineStyle = xlNone
                With .Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                .Borders(xlEdgeRight).LineStyle = xlNone
                .Borders(xlInsideVertical).LineStyle = xlNone
                .Borders(xlInsideHorizontal).LineStyle = xlNone
            End With
        
        End With
        
        'From Owner Rev Deck Worksheet
        With wsFromOwner
        
            lngLastRow = .UsedRange.Rows.Count
            If lngLastRow = 1 Then lngLastRow = 2
            
            'Clear all data
            Call ClearSheet(.Range("A2:AM" & lngLastRow))
            
        End With
        
        'From To Rev Deck Worksheet
        With wsToOwner
        
            lngLastRow = .UsedRange.Rows.Count
            If lngLastRow = 1 Then lngLastRow = 2
            
            'Clear all data
            Call ClearSheet(.Range("A2:AM" & lngLastRow))
            
            'Default A2 to 'NEW'
            .Range("A2").Value = "NEW"
        
        End With
        
        'SUSPENSE Worksheet
        If WorksheetExists("SUSPENSE") Then
            Call ClearSheet(wsSuspense.Cells)
        End If
        
        'SUSPENSE (2) Worksheet
        If WorksheetExists("SUSPENSE (2)") Then
            Call ClearSheet(wsSuspense2.Cells)
        End If
        
        'FileName Worksheet
        With wsFileName
            
            'Reset formulas
            .Range("B2").FormulaR1C1 = _
                    "=CONCATENATE(Transfer!R4C2,""_"",Transfer!R3C5,""_"",Transfer!R17C1,"" "",+Transfer!R17C2,"" TO "",+Transfer!R24C1,"" "",+Transfer!R24C2)"
            .Range("B3").FormulaR1C1 = _
                    "=CONCATENATE(Transfer!R[1]C,"" ("",Transfer!R[14]C[-1],""_"",Transfer!R[21]C[-1],"") "",Transfer!RC[3])"
        
            .Range("rngFileName").Offset(0, 1).ClearContents
            .Range("rngWordFooter").Offset(0, 1).ClearContents
            
        End With
        
        'Default cursor to Cell A1
        Call ResetWorksheetsCellA1
        
        MsgBox "Workbook has been successfully reset!"
        
    End If


End Sub
'Creates the concatenated filename and copies to clipboard
Public Sub SaveFile()
Attribute SaveFile.VB_Description = "Saves as an XLSM file (with macros)"
Attribute SaveFile.VB_ProcData.VB_Invoke_Func = "M\n14"
    
    With wsFileName
        
        .Range("rngFileName").Offset(0, 1).ClearContents
        .Range("rngFileName").Copy
        .Range("rngFileName").Offset(0, 1).PasteSpecial xlPasteValues
        .Range("rngFileName").Offset(0, 1).Copy
        
        Application.Goto .Range("rngFileName").Offset(0, 1)
        
        Call SaveAsXLSM
    
    End With


End Sub
'Creates the Word footer
Public Sub CreateWordFooter()
Attribute CreateWordFooter.VB_Description = "Create Word Footer for Division Orders per naming standard established"
Attribute CreateWordFooter.VB_ProcData.VB_Invoke_Func = "F\n14"
    
    Dim intStart, intLength As Integer


    With wsFileName
        
        .Range("rngWordFooter").Offset(0, 1).ClearContents
        .Range("rngWordFooter").Copy
        .Range("rngWordFooter").Offset(0, 1).PasteSpecial xlPasteValues
        
        intStart = InStrRev(Trim(.Range("rngWordFooter").Offset(0, 1)), ")")
        intStart = intStart + 2
        intLength = Len(Trim(.Range("rngWordFooter").Offset(0, 1))) - (intStart - 1)
        
        .Range("rngWordFooter").Offset(0, 1).Characters(Start:=intStart, Length:=intLength).Font.ColorIndex = 3
                
        .Range("rngWordFooter").Offset(0, 1).Copy
        
        Application.Goto .Range("rngWordFooter").Offset(0, 1)
        MsgBox "Word Footer has been copied to the clipboard.", vbInformation, "Word Footer"
    
    End With


End Sub
'Places the cursor on Cell A1 for all visible worksheets
Public Sub ResetWorksheetsCellA1()
Attribute ResetWorksheetsCellA1.VB_Description = "Sets location of cursor on all worksheets in workbook to Cell A1"
Attribute ResetWorksheetsCellA1.VB_ProcData.VB_Invoke_Func = "T\n14"


    Dim ws As Worksheet


    'Default cursor to Cell A1
    For Each ws In ThisWorkbook.Worksheets
        If ws.Visible = xlSheetVisible Then
            Application.Goto ws.Range("A1"), True
        End If
    Next ws
    
    Application.Goto wsTransfer.Range("A1"), True


End Sub
'Saves a copy of the workbook as an .xlsx file
Public Sub SaveAsXLSX()
Attribute SaveAsXLSX.VB_Description = "Saves as XLSX file (NO macros)"
Attribute SaveAsXLSX.VB_ProcData.VB_Invoke_Func = "N\n14"
    
    Dim bFileSaveAs As Boolean
    Dim i As Integer: i = 1
    Dim strFileName As String
    Dim strFullPath As String
    Dim fNameAndPath As Variant
    Dim wb As Workbook
    Dim ws As Worksheet
    
    On Error GoTo Err_Save
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    
    'Determine the default file name
    strFileName = Trim(wsFileName.Range("rngFileName").Offset(0, 1))
    If strFileName <> "" Then
        strFileName = strFileName & ".xlsx"
    End If
    
    'Place cursor to A1 for all sheets
    Call ResetWorksheetsCellA1
    
    'Create a copy of this workbook
    Set wb = Workbooks.Add
    
    On Error Resume Next
    For Each ws In wb.Worksheets
        ws.Delete
    Next
    On Error GoTo 0


    For Each ws In ThisWorkbook.Sheets
        ws.Copy After:=wb.Sheets(i)
        i = i + 1
    Next
    wb.Sheets(1).Delete
            
    'Prompt user to save
    If wsFileName.Range("rngSavePath") <> "" Then
        strLastPath = Trim(wsFileName.Range("rngSavePath"))
        If Right(strLastPath, 1) <> "\" Then strLastPath = strLastPath & "\"
    Else
        strLastPath = ThisWorkbook.Path & "\"
    End If
    
    strFullPath = strLastPath & strFileName
    fNameAndPath = Application.GetSaveAsFilename(InitialFileName:=strFullPath, FileFilter:="Excel Workbook(*.xlsx), *.xlsx", Title:="Save As")
    
    'If user cancels, abort
    If fNameAndPath = False Then
        wb.Close
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Application.EnableEvents = True
        Exit Sub
    End If
    
    Application.Goto wb.Sheets("Transfer").Range("A1"), True
    Call BreakExternalLinks(wb, strFileName)
    wb.SaveAs Filename:=fNameAndPath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    wb.Close
    
    'Set last save path
    wsFileName.Range("rngSavePath") = Left(fNameAndPath, InStrRev(fNameAndPath, "\"))
    
    Set fNameAndPath = Nothing
    Set wb = Nothing
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    MsgBox "A copy of this workbook has been saved to: " & vbCrLf & vbCrLf & strFullPath, vbInformation, "Saved"
    
    Exit Sub
    
Err_Save:


    If Not wb Is Nothing Then wb.Close
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    MsgBox "An error has occurred: " & Err.Number & " - " & Err.Description, vbCritical, "Error"
    
End Sub


'Saves a copy of the workbook as an .xlsm file
Private Sub SaveAsXLSM()
    
    Dim bFileSaveAs As Boolean
    Dim i As Integer: i = 1
    Dim strFileName As String
    Dim strFullPath As String
    Dim fNameAndPath As Variant
    Dim wb As Workbook
    Dim ws As Worksheet
    
    On Error GoTo Err_Save
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    
    'Determine the default file name
    strFileName = Trim(wsFileName.Range("rngFileName").Offset(0, 1))
    If strFileName <> "" Then
        strFileName = strFileName & ".xlsm"
    End If
    
    'Place cursor to A1 for all sheets
    Call ResetWorksheetsCellA1
    
    Set wb = ThisWorkbook
                
    'Prompt user to save
    If wsFileName.Range("rngMacroSavePath") <> "" Then
        strLastPath = Trim(wsFileName.Range("rngMacroSavePath"))
        If Right(strLastPath, 1) <> "\" Then strLastPath = strLastPath & "\"
    Else
        strLastPath = ThisWorkbook.Path & "\"
    End If
        
    strFullPath = strLastPath & strFileName
    fNameAndPath = Application.GetSaveAsFilename(InitialFileName:=strFullPath, FileFilter:="Excel Macro-Enabled Workbook(*.xlsm), *.xlsm", Title:="Save As")
    
    'If user cancels, abort
    If fNameAndPath = False Then
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Application.EnableEvents = True
        Exit Sub
    End If
    
    Application.Goto wb.Sheets("Transfer").Range("A1"), True
    wb.SaveCopyAs Filename:=fNameAndPath
    
    'Set last save path
    wsFileName.Range("rngMacroSavePath") = Left(fNameAndPath, InStrRev(fNameAndPath, "\"))
    
    Set fNameAndPath = Nothing
    Set wb = Nothing
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    MsgBox "A copy of this workbook has been saved to: " & vbCrLf & vbCrLf & strFullPath, vbInformation, "Saved"
    
    Exit Sub
    
Err_Save:


    If Not wb Is Nothing Then wb.Close
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    MsgBox "An error has occurred: " & Err.Number & " - " & Err.Description, vbCritical, "Error"
    
End Sub


'Removes extra rows added by user prior to resetting workbook
Private Sub DeleteExtraRows(ByRef rngTarget As Range, intOffset As Integer)


    If rngTarget.Offset(intOffset, 0) = "" Then
        Do Until rngTarget.Offset(intOffset, 0) <> ""
            rngTarget.Offset(1, 0).EntireRow.Delete xlShiftUp
        Loop
    End If


End Sub
'Clears contents of range specified
Private Sub ClearSheet(ByRef rngTarget As Range)
    
    rngTarget.ClearContents
    With rngTarget.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
End Sub
'Checks if worksheet exists
Private Function WorksheetExists(wsName As String) As Boolean


    Dim ws: For Each ws In Sheets
        WorksheetExists = (wsName = ws.Name): If WorksheetExists Then Exit Function
    Next ws
    
End Function


Private Sub BreakExternalLinks(wb As Workbook, strName As String)
    
    Dim ExternalLinks As Variant
    Dim x As Long
        
'    'Create an Array of all External Links stored in Workbook
'    ExternalLinks = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
'
'    'Loop Through each External Link in ActiveWorkbook and Break it
'    For x = 1 To UBound(ExternalLinks)
'        wb.BreakLink Name:=ExternalLinks(x), Type:=xlLinkTypeExcelLinks
'    Next x


    wb.ChangeLink Name:=ThisWorkbook.Name, NewName:=strName, Type:=xlExcelLinks


End Sub
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
dfolzenlogen said:
... I've added the macros to a Custom Ribbon tab and also added then to the Quick Access Toolbar...
Click to expand...
Hi,

When you manually set macros of a template workbook to controls added on a QAT or on a Custom Ribbon tab, then link to the full path name of that template workbook is established.
To solve this issue, you need to embed Ribbon/QAT controls inside customUI.xml or customUI14.xml part of your template file. When opening a copy of a template workbook auto creates controls on Ribbon/QAT linked to the macros of that workbook.
Read more details with examples in this great site of Ron de Bruin: https://www.rondebruin.nl/win/section2.htm

Regards
 
Last edited:
Upvote 0
Thank you. I'll give it a read.

ZVI said:
Hi,

When you manually set macros of a template workbook to controls added on a QAT or on a Custom Ribbon tab, then link to the full path name of that template workbook is established.
To solve this issue, you need to embed Ribbon/QAT controls inside customUI.xml or customUI14.xml part of your template file. When opening a copy of a template workbook auto creates controls on Ribbon/QAT linked to the macros of that workbook.
Read more details with examples in this great site of Ron de Bruin: https://www.rondebruin.nl/win/section2.htm

Regards
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Question Question
File is allready saved but code should be stopping duplicates being saved
Replies
5
Views
263
ipbr21054
I
I
  • Solved
Msgbox is shown whether file is saved or not
Replies
4
Views
248
Alex Blakenburg
A
R
  • Question Question
VBA - AUTO FIT, Can we remove make the sum formula in below code
Replies
1
Views
151
Joe4
Joe4
L
  • Locked
  • Question Question
Help Cleaning Up Code
Replies
2
Views
576
RoryA
RoryA
K
  • Question Question
VBA DOUBT- can we add heading color and remove blank columns in this code?
Replies
0
Views
156
Kishore1982
K

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top