Simple VBA Code help

[Rob_010101]

Hello,

My excel is a master document that pulls in data from different excel sheets in different departments, each of which are all updated daily. I need to save the "master" excel once a week into a different excel with all the values pasted. This creates a weekly snapshot of the data as it is at the point of saving but leaves the "master" excel with all the formulas, so it keeps updating.

I have tried to use the below assigned to a button however in addition to creating a new document with paste values, it is also pasting values in the "master" document rendering it useless.

Sub MakeBook()
Dim sh As Worksheet
For Each wb In Sheets
    wb.Activate
    Cells.Copy
    Range("A1").PasteSpecial Paste:=xlPasteValues
Next
With ActiveWorkbook
    s = Replace(.FullName, .Name, Format(Date, "dd-mmm-yy")) & ".xlsm"
End With
ActiveWorkbook.SaveAs Filename:=s
End Sub

It should "Save As" and save into a new excel, as the date, with values pasted. The "master" excel i.e. the sheet being saved from should retain all the formulas.

Hope that makes sense.

Chris

 

[rlv01]

Something like this perhaps.

Sub MakeBook()
    Dim sh As Worksheet, wb As Workbook, s As String
  
    With ActiveWorkbook
        s = Replace(.FullName, .Name, Format(Date, "dd-mmm-yy")) & ".xlsm"
        .SaveCopyAs s
    End With  
    Set wb = Workbooks.Open(FileName:=s)
    For Each sh In wb.Worksheets
        sh.UsedRange.Value = sh.UsedRange.Value
    Next sh
    wb.Close Savechanges:=True
    MsgBox "New workbook '" & s & "' has been created. ", vbOKOnly, Application.Name
End Sub

 

[Rob_010101]

Something like this perhaps.

Sub MakeBook()
    Dim sh As Worksheet, wb As Workbook, s As String
 
    With ActiveWorkbook
        s = Replace(.FullName, .Name, Format(Date, "dd-mmm-yy")) & ".xlsm"
        .SaveCopyAs s
    End With 
    Set wb = Workbooks.Open(FileName:=s)
    For Each sh In wb.Worksheets
        sh.UsedRange.Value = sh.UsedRange.Value
    Next sh
    wb.Close Savechanges:=True
    MsgBox "New workbook '" & s & "' has been created. ", vbOKOnly, Application.Name
End Sub

 

[Rob_010101]

View attachment 106572

 

[rlv01]

Sub MakeBook()
    Dim sh As Worksheet, wb As Workbook, s As String
    
    With ActiveWorkbook
        If .Path = "" And Left(.Name, 4) = "Book" Then
            MsgBox "'" & .Name & "' is a new workbook that has never been saved and thus has no path to build a new filename with. Please run this macro on a workbook that has been" _
            & " previously been saved to disk. ", vbOKOnly Or vbExclamation, Application.Name
            Exit Sub
        End If
        
        s = Replace(.FullName, .Name, Format(Date, "dd-mmm-yy")) & ".xlsm"
        
        For Each wb In Workbooks
            If UCase(wb.FullName) = UCase(s) Then
                MsgBox "Please close workbook '" & wb.Name & "' before proceeding", vbOKOnly Or vbExclamation, Application.Name
                Exit Sub
            End If
        Next wb
        
        Select Case MsgBox("The workbook you have selected for processing is:" & vbCrLf _
                & "" & vbCrLf _
                & "Name: '" & .Name & "'" & vbCrLf _
                & "Path: '" & .Path & "'" & vbCrLf & vbCrLf _
                & "New workbook to be created: '" & s & "'" & vbCrLf & vbCrLf _
                & "Continue?", vbYesNo, Application.Name)
            Case vbNo
                Exit Sub
        End Select
        
        If UCase(s) = UCase(.FullName) Then
            s = Split(s, ".")(0) & "_Copy" & ".xlsm"
        End If
        
        .SaveCopyAs s
        DoEvents
    End With
    
    Set wb = Workbooks.Open(Filename:=s)
    For Each sh In wb.Worksheets
        sh.UsedRange.Value = sh.UsedRange.Value
        DoEvents
    Next sh
    wb.Save
    wb.Close Savechanges:=False
    MsgBox "New workbook '" & s & "' has been created. ", vbOKOnly, Application.Name
End Sub

 

[Rob_010101]

Hi

I'm still getting

The file is on SharePoint and seems to be trying to save to a web address, might this be the issue?

 

[rlv01]

It is important to always mention that you are using SharePoint file paths. That changes things significantly as not all VBA file functions work with SharePoint 'http' style paths. Runtime error 1004 is specific to a line of code; but your screen shot does not indicate which one. Which line of code produces the runtime error 1004?

 

[Rob_010101]

It is important to always mention that you are using SharePoint file paths. That changes things significantly as not all VBA file functions work with SharePoint 'http' style paths. Runtime error 1004 is specific to a line of code; but your screen shot does not indicate which one. Which line of code produces the runtime error 1004?

Apologies, I only realised this when you added the helpful message and it showed the full path.

Unfortunately, the editor doesn't highlight the line of code the error applies to.

 

[rlv01]

Unfortunately, the editor doesn't highlight the line of code the error applies to.

In the VBA editor menu, go to the Tools->Options->General tab. Set "Break on All Errors".

(Alternatively, move the code out of the Workbook code module into a standard code module that you add).

Re-run the code. When the runtime error occurs, press the 'Debug' button to determine the line of code.

 

[rlv01]

I think the problem has to do with .SaveCopyAs s ,since for whatever reason, MS chose not to modify that function to support SharePoint & OneDrive http style paths. See if this works for you.

Sub MakeBook()
    Dim sh As Worksheet, wb As Workbook, s As String, ABFilePath As String
    Set wb = ActiveWorkbook
    
    ABFilePath = wb.FullName
    s = Replace(wb.FullName, wb.Name, Format(Date, "dd-mmm-yy")) & ".xlsm"
    
    For Each sh In wb.Worksheets
        sh.UsedRange.Value = sh.UsedRange.Value
    Next sh
    
    wb.SaveAs Filename:=s                       'save to SharePoint filepath
    DoEvents
    MsgBox "New workbook '" & s & "' has been created. ", vbOKOnly, Application.Name
    Workbooks.Open Filename:=ABFilePath         're-open original workbook
    wb.Close Savechanges:=False 'exit
End Sub