・ファイルを開いた時にフォルダー作成する

Sub オープン時に個人用にBackUp()

Dim MPath, SPath, FileName, FilePath, backupFilePath

'フォルダパスを指定します

MPath = ThisWorkbook.Path

SPath = ThisWorkbook.Path & "\BackUp"

'ファイル名を指定します

FileName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)

    If Dir(SPath, vbDirectory) = "" Then 'BACKUP用フォルダーがあるか？

        MkDir SPath 'BACKUP用フォルダーを作成します。

    End If

        backupFilePath = SPath & "\" & FileName & ".xlsm"

    ActiveWorkbook.SaveCopyAs backupFilePath

    MsgBox "個人用作成しました"

End Sub

・登録時にフォルダーに自身のファイルコピーを作成する

Sub 登録時に()

Dim MPath, SPath, FileName, FilePath, backupFilePath

'フォルダパスを指定します

MPath = ThisWorkbook.Path

SPath = kanriALL

'このファイル名を指定します

FileName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)

    Dim MotoCopy, SakiCopy As String

    Dim Rc As Integer

    backupFilePath = SPath & "\" & FileName & ".xlsm"

    ActiveWorkbook.SaveCopyAs backupFilePath

    MsgBox "管理者ALL作成しました"

End Sub