VBA Saved Workbook in multiple folders and Save with cell value

[bored622]

Hello everyone,

I'm trying to create a button where the macro saves the workbook in three different folders and names the workbook using cell AD. Cell AD has the formula =TEXT(NOW(),"MM.DD.YY H.MM AM/PM"). I know how to save sheets in multiple folders but have never done this with an entire workbook. Any help is appreciated.

 

[John_w]

Try this macro, after changing the sheet name of the AD1 cell ("Sheet1" below) and the three folder paths.

Public Sub Create_Workbook_Copies()

    Dim fileName As String
    Dim p As Long
    Dim tempCopy As String
    Dim tempWorkbook As Workbook
    Dim ws As Worksheet
    
    'Create a temporary copy of this .xlsm/.xlsb file
    
    With ThisWorkbook
        fileName = .Worksheets("Sheet1").Range("AD1").Value & ".xlsx"    
        p = InStrRev(.FullName, ".")
        tempCopy = Left(.FullName, p - 1) & " TEMP COPY" & Mid(.FullName, p)
        .SaveCopyAs tempCopy
    End With
        
    'Open the temporary copy, change formulas in all sheets to values and save workbook as a .xlsx file in 3 folders
    
    Set tempWorkbook = Workbooks.Open(tempCopy)
    For Each ws In tempWorkbook.Worksheets
        ws.UsedRange.Value = ws.UsedRange.Value
    Next
    Application.DisplayAlerts = False 'suppress warning if .xlsx file exists - the file is replaced
    tempWorkbook.SaveAs "C:\path\to\folder1\" & fileName, xlOpenXMLWorkbook
    tempWorkbook.SaveAs "C:\path\to\folder2\" & fileName, xlOpenXMLWorkbook
    tempWorkbook.SaveAs "C:\path\to\folder3\" & fileName, xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    tempWorkbook.Close False
    
    'Delete the temporary copy
    
    Kill tempCopy
    
End Sub

 

[bored622]

I'm getting an error in ws.UsedRange.Value = ws.UsedRange.Value when I try to debug it

 

[bored622]

Try this macro, after changing the sheet name of the AD1 cell ("Sheet1" below) and the three folder paths.

Public Sub Create_Workbook_Copies()

    Dim fileName As String
    Dim p As Long
    Dim tempCopy As String
    Dim tempWorkbook As Workbook
    Dim ws As Worksheet
   
    'Create a temporary copy of this .xlsm/.xlsb file
   
    With ThisWorkbook
        fileName = .Worksheets("Sheet1").Range("AD1").Value & ".xlsx"   
        p = InStrRev(.FullName, ".")
        tempCopy = Left(.FullName, p - 1) & " TEMP COPY" & Mid(.FullName, p)
        .SaveCopyAs tempCopy
    End With
       
    'Open the temporary copy, change formulas in all sheets to values and save workbook as a .xlsx file in 3 folders
   
    Set tempWorkbook = Workbooks.Open(tempCopy)
    For Each ws In tempWorkbook.Worksheets
        ws.UsedRange.Value = ws.UsedRange.Value
    Next
    Application.DisplayAlerts = False 'suppress warning if .xlsx file exists - the file is replaced
    tempWorkbook.SaveAs "C:\path\to\folder1\" & fileName, xlOpenXMLWorkbook
    tempWorkbook.SaveAs "C:\path\to\folder2\" & fileName, xlOpenXMLWorkbook
    tempWorkbook.SaveAs "C:\path\to\folder3\" & fileName, xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    tempWorkbook.Close False
   
    'Delete the temporary copy
   
    Kill tempCopy
   
End Sub

The run-time error 1004 is saying the cell or chart you're trying to change is on a protected sheet. To make a change, unprotect the sheet.

 

[bored622]

Try this macro, after changing the sheet name of the AD1 cell ("Sheet1" below) and the three folder paths.

Public Sub Create_Workbook_Copies()

    Dim fileName As String
    Dim p As Long
    Dim tempCopy As String
    Dim tempWorkbook As Workbook
    Dim ws As Worksheet
   
    'Create a temporary copy of this .xlsm/.xlsb file
   
    With ThisWorkbook
        fileName = .Worksheets("Sheet1").Range("AD1").Value & ".xlsx"   
        p = InStrRev(.FullName, ".")
        tempCopy = Left(.FullName, p - 1) & " TEMP COPY" & Mid(.FullName, p)
        .SaveCopyAs tempCopy
    End With
       
    'Open the temporary copy, change formulas in all sheets to values and save workbook as a .xlsx file in 3 folders
   
    Set tempWorkbook = Workbooks.Open(tempCopy)
    For Each ws In tempWorkbook.Worksheets
        ws.UsedRange.Value = ws.UsedRange.Value
    Next
    Application.DisplayAlerts = False 'suppress warning if .xlsx file exists - the file is replaced
    tempWorkbook.SaveAs "C:\path\to\folder1\" & fileName, xlOpenXMLWorkbook
    tempWorkbook.SaveAs "C:\path\to\folder2\" & fileName, xlOpenXMLWorkbook
    tempWorkbook.SaveAs "C:\path\to\folder3\" & fileName, xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    tempWorkbook.Close False
   
    'Delete the temporary copy
   
    Kill tempCopy
   
End Sub

I unprotected all the sheets and the formula worked but is there a way to save it by having certain sheets protected? My only concern is that if others were to use the excels they may break the formulas.

 

[bored622]

I unprotected all the sheets and the formula worked but is there a way to save it by having certain sheets protected? My only concern is that if others were to use the excels they may break the formulas.

I figured out a workaround if anyone had the same concerns I had. I unprotected all of my sheets and coded some VBA code within the sheets that would undo any changes to locked cells even when the sheet is unprotected. Below is the code i used within each sheet. i didn't want users messing around in.

Private Sub Worksheet_Change(ByVal Ta
Private Sub Worksheet_Change(ByVal Target As Range)
For Each i In Target
If i.Locked = True Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
MsgBox "Your action was undone because it made changes to a locked cell.", , "Action Undone"
Exit For
End If
Next i
End Sub

 

[John_w]

The run-time error 1004 is saying the cell or chart you're trying to change is on a protected sheet. To make a change, unprotect the sheet.

I unprotected all the sheets and the formula worked but is there a way to save it by having certain sheets protected?

The revised code below unprotects each sheet, if it is protected, with either a blank password or "Excel" and reprotects the sheet.

Replace the For Each ws In tempWorkbook.Worksheets .... Next code with:

    Dim ErrNum As Long, protectPassword As String

    For Each ws In tempWorkbook.Worksheets
        If ws.ProtectContents Then
            protectPassword = ""
            On Error Resume Next
            ws.Unprotect Password:=protectPassword
            ErrNum = Err.Number
            On Error GoTo 0
            If ErrNum <> 0 Then
                protectPassword = "Excel"
                ws.Unprotect Password:=protectPassword
            End If
            ws.UsedRange.Value = ws.UsedRange.Value
            ws.Protect Password:=protectPassword
        Else
            ws.UsedRange.Value = ws.UsedRange.Value
        End If
    Next