簡単エクセルマクロ日記

説明は苦手なのであしからず

ファイルのバックアップ作成

ボタンを押すとファイルをバックアップするプログラム。



<プログラム>

Private Sub BackUp_Click()
On Error Resume Next

ThisWorkbook.Save

If Err.Number <= 0 Then
    'デスクトップにバックアップフォルダを作成した場合
    Dim backupPath As String
    backupPath = "C:\Users\" & Application.UserName & "\Desktop\" & Format(Date,"YYYY") & "_bk"

    '古いバックアップを消す
    Call trushClear(backupPath)

    'ファイル移動オブジェクト(複数用)
    Dim objFSO As Object, txtSource As String, txtDestination
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'バックアップのコピー
    Call copyNewBk(objFSO)

End If

End Sub


Private Sub trushClear(backupPath As String)
    
    'バックアップフォルダの存在チェック
    If Dir(backupPath, vbDirectory) = "" Then
        MkDir backupPath
    End If

    '※ファイル名は任意
    If Dir(backupPath & "\" & Format(Date, "yyyymmdd") & "残したいファイル_*.xlsm") <> "" Then
        Kill backupPath & "\" & Format(Date, "yyyymmdd") & "残したいファイル_*.xlsm"
    End If

    
End Sub


Private Sub copyNewBk(backupPath As String, objFSO As Object)

    '残したいファイル ※objFSO.CopyFileは、開いていてもコピーできる(最後に保存されたタイミングのコピーとなる)
    objFSO.CopyFile ThisWorkbook.FullName, backupPath  & "\残したいファイル_" & Format(Date, "yyyymmdd") & ".xlsm"


'    '参考 ※FileCopyは、開いているファイルはコピーできない
'    FileCopy "バックアップを取りたいファイルが置かれているフォルダ/" & "\残したいファイル_" & Format(Date, "yyyymmdd") & ".xlsm", backupPath  & "\残したいファイル_" & Format(Date, "yyyymmdd") & ".xlsm"

End Sub


<オマケ>
ファイルをカウントする。

Private Function countFile(filePath As String, fileName As String) As Long

    Dim cnt As Long
    Dim tmp  As String
    cnt = 1
    tmp = Dir(filePath & "\" & fileName)

    Do While tmp <> ""
        cnt = cnt + 1
        tmp = Dir()
    Loop
    
    countFile = cnt
    
End Function