« ruby-list:47543のブロックの話題。なるほど。あんまり意識したことないけど意識しないとはまりますね。 | トップページ | iPhoneで最近バッテリーの消耗が激しくなった人はきっとアプリの起動しすぎです。 »

複数人で同じエクセルファイルをつつくと思わぬ事故にあうので、変更されたら勝手にバックアップを作っていくようなマクロを作った。あちこちのサイトを参考にさせて頂きました。

'変数名が日本語になっているものがあるが、
'VBAの最大にして唯一の良さだと思っているので、気にしないで欲しい。(^^
'このマクロを使うと、シートを変更した瞬間に分単位で変更前の状態を
'保存するだけ(秒単位まではできる)です。
'変更前の状態というのが微妙で、Workbook_SheetChange が呼び出される直前と直後というだけです。
'Undoを使って変更前の情報を取得するところはこちらに書いてあって、面白いアイデアですね。
'ファイルの保存時には「ファイル履歴」というシートが勝手に作られて、
'そこに保存日付とファイルサイズが記録されていく。それだけのマクロです。
'バックアップファイルは、「bakcup_ファイル名」というディレクトリが勝手に
'カレントディレクトリに作られるので、その中に分単位とか秒単位で保存されて
'いくだけです。
'1時間ほどでつくったものなので、しっかり検証していません。
'自己責任で参考にしましょう。参考にならない可能性の方が大きいが。

'開いているエクセルファイルの更新時刻を取得する
Function GetUpdateTime() As String
    Dim wApplication As Application
    Dim wFileName As String
    Dim wAttribute As Integer
    Dim wReturn As String

    Set wApplication = Application
    ' ファイル名の指定

    wFileName = ActiveWorkbook.FullName
    ' ファイル属性の取得
    wAttribute = GetAttr(wFileName)

    ' 更新日時
    wReturn = FileDateTime(wFileName)

    ' 処理結果を表示
    GetUpdateTime = wReturn
End Function

'開いているエクセルファイルのサイズを取得する
Function GetFileLength() As String
    Dim wApplication As Application
    Dim wFileName As String
    Dim wAttribute As Integer
    Dim wReturn As String

    Set wApplication = Application
    ' ファイル名の指定

    wFileName = ActiveWorkbook.FullName

    ' ファイル属性の取得
    wAttribute = GetAttr(wFileName)

    ' 更新日時
    wReturn = FileLen(wFileName)

    ' 処理結果を表示
    GetFileLength = wReturn
End Function

'指定したシート名のシートが存在するかをチェックする
Function IsExistSheet(aSheetName As String) As Boolean
    Dim ws As Worksheet, flag As Boolean
    Dim wReturn As Boolean
    
    For Each ws In Worksheets
        If ws.Name = aSheetName Then flag = True
    Next ws
    If flag = True Then
        wReturn = True
    Else
        wReturn = False
    End If
    IsExistSheet = wReturn
End Function

'指定した文字列に日付と時刻を指定して一意なファイル名を生成する
'一意と言っても、分単位とか秒単位にするだけだが。
Function CreateFileName(aName As String) As String
    Dim wHizuke As String
    Dim wJikan As String
    
    wHizuke = Format(Date, "yyyymmdd")
    wJikan = Hour(Time) & Minute(Time) ' & Second(Time)
    
    CreateFileName = wHizuke & wJikan & "_" & aName
End Function

'指定したパスのディレクトリがなかったら勝手に作る
Sub CreateFolder(aPath As String)
    If Dir$(aPath, vbDirectory) = "" Then
        MkDir aPath
    End If
End Sub

Const HISTORY_FILE_NAME = "ファイル履歴"
Const BACKUP_FOLDER_NAME_PREFIX = "backup_"

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    If IsExistSheet(HISTORY_FILE_NAME) = False Then
        Application.EnableEvents = False
        
        Sheets.Add
        ActiveSheet.Name = HISTORY_FILE_NAME
        Sheets(HISTORY_FILE_NAME).Cells(1, 1) = "更新日付"
        Sheets(HISTORY_FILE_NAME).Cells(1, 2) = "ファイルサイズ(byte)"
    
        Application.EnableEvents = True
    End If

    wLastRowIndex = Sheets(HISTORY_FILE_NAME).UsedRange.Rows.Count
    Application.EnableEvents = False
    Sheets(HISTORY_FILE_NAME).Cells(wLastRowIndex + 1, 1) = "'" & GetUpdateTime
    Sheets(HISTORY_FILE_NAME).Cells(wLastRowIndex + 1, 2) = GetFileLength
    Sheets(HISTORY_FILE_NAME).Columns("A:B").AutoFit
    Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim wBackupFileName As String
    Dim wBackupFolderName As String
    Dim w変更前 As Variant
    Dim w変更後 As Variant
    
    If Target.Count <> 1 Then
        Exit Sub
    Else
        w変更後 = Target
        Application.EnableEvents = False
        Application.Undo
        w変更前 = Target
        Target.Value = w変更前

        wBackupFileName = CreateFileName(ActiveWorkbook.Name)
        wBackupFolderName = ActiveWorkbook.Path & "\" & BACKUP_FOLDER_NAME_PREFIX & ActiveWorkbook.Name
        CreateFolder wBackupFolderName
        ActiveWorkbook.SaveCopyAs wBackupFolderName & "\" & wBackupFileName
        
        Target = w変更後
        Application.EnableEvents = True
    End If
End Sub

« ruby-list:47543のブロックの話題。なるほど。あんまり意識したことないけど意識しないとはまりますね。 | トップページ | iPhoneで最近バッテリーの消耗が激しくなった人はきっとアプリの起動しすぎです。 »

パソコン・インターネット」カテゴリの記事

コメント

コメントを書く

(ウェブ上には掲載しません)

トラックバック

« ruby-list:47543のブロックの話題。なるほど。あんまり意識したことないけど意識しないとはまりますね。 | トップページ | iPhoneで最近バッテリーの消耗が激しくなった人はきっとアプリの起動しすぎです。 »

2013年12月
1 2 3 4 5 6 7
8 9 10 11 12 13 14
15 16 17 18 19 20 21
22 23 24 25 26 27 28
29 30 31        

最近の記事

最近のコメント

最近のトラックバック

無料ブログはココログ