Autosave every friday

[gerald24]

Hi Guys,

Could you help me with the codes below?
What I want to accomplish is for the codes to save back up ONLY ON FRIDAYS but my codes are not working.

Sub Time_In()
Dim FileName As String
' Keyboard Shortcut: Ctrl+e
'
    'On cell and saves file
    Sheets("TITO").Select
    ActiveCell.Offset(0, 0).Select
    ActiveCell.Value = Format(Now(), "HH:MM mm/dd/yyyy")
    ActiveCell.NumberFormat = "h:mm AM/PM"
    
    Call Shift 'ignore this in this question
    
If Weekday(Now(), vbFriday) Then
    
    Application.DisplayAlerts = False
    For Each w In Application.Workbooks
    w.Save
    FileName = ActiveWorkbook.Name
    ActiveWorkbook.SaveAs FileName:="\\Pathfile\" & FileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Application.DisplayAlerts = True
    w.Close
    
    Next w

    End If

   
End Sub

 

[CrispyAsian]

Try this:

If Weekday(Now()) = vbFriday Then

Dim FileName As String

Application.DisplayAlerts = False

ActiveWorkbook.Save

FileName = ActiveWorkbook.Name

With ActiveWorkbook
.SaveAs([COLOR=#ff0000]"\\PathFile\" [/COLOR]& FileName, FileFormat:=52
.Close 0
End With

Application.DisplayAlerts = True

End If

Make sure that you change the "\\PathFile" that I highlighted to the file path where you want the document to be saved. Let me know if this works for you.