VBAでafter_saveのコピーを保存し、無限ループに入ります。

Question

ユーザーがシートを保存したときに実行するコードを作成しました。このコードは別のコピーを保存し、元のファイルを再度保存します。 ただし、元のファイルを再度保存すると、「after_save」トリガーが発生し、無限に保存されます。 ここで解決策を確認してくださいStackOverFlowしかし、私の問題を解決したものは見つかりません。

Private Sub Workbook_AfterSave(ByVal Success As Boolean) 
Call SaveToLocations 
End Sub 

Sub SaveToLocations() 
Dim WoExt, Ext, BkPath, nDateTime As String 
    Static OrigName As String 

    'defining variables 
    nDateTime = Format(Now, "YYMMDD") 
    OrigName = "C:\Users\xxx.xxx\Desktop\vbatest\test orig.xlsm" 
    Ext = ".xls" 
    WoExt = "test orig" 
    BkPath = "C:\Users\xxx.xxx\Desktop\vbatest\Backup\" 
     Application.DisplayAlerts = False 
     ActiveWorkbook.SaveAs (BkPath + WoExt + " - Backup - " + nDateTime + Ext) 
     ActiveWorkbook.SaveAs OrigName 
     Application.DisplayAlerts = True 
End Sub 

Answer 1

アーカイブを作成するには、ブックを開くときにブックを保存する必要があります。ユーザーがブックを閉じるときに最後に保存する必要はありません。以下のコードはこれを処理します：

Private Sub Auto_Open() 
Dim WoExt, Ext, BkPath, nDateTime As String 

On Error GoTo ErrorHandler: 

    'defining variables 
    nDateTime = Format(Now, "YYMMDD") 
    Ext = ".xls" 
    WoExt = ThisWorkbook.Name 
    BkPath = "C:\Users\xxx.xxx\Desktop\vbatest\Backup\" 

     Application.DisplayAlerts = False 
     ActiveWorkbook.SaveCopyAs (BkPath + WoExt + " - Backup - " + nDateTime + Ext) 
     Application.DisplayAlerts = True 


Exit Sub 

ErrorHandler: 
      MsgBox "Backup has not been saved." 
End Sub 

これはちょうどバックアップを保存し、最後にユーザーに編集内容を保存します。