エクセル2007で下記仕様のVBAコードを教えて頂けませんか。

やりたい事:
PCのDドライブに存在する「backup」というフォルダに、同一PCのCドライブ内に存在するexample1,example2というフォルダをバックアップを目的として保存する。
example1,example2内資料は定期的に変更されるので、その後バックアップは定期的に行う。
①バックアップが終了するまで「ファイル保存中です」のMsg Boxを表示させる
②バックアップが終了すると「ファイル保存完了!」 ”OK”Msg Boxを表示させ、”OK”をクリックするとMsg Boxを消す
状況等:
1)example1,example2フォルダ内資料は、システムファイル(Thumbs.db)、読取専用ファイルが混在している為?、FSOで単純にフォルダの上書きバックアップが出来ない。

分かりにくい質問で申し訳ありませんがよろしくお願いします。

回答の条件
  • 1人10回まで
  • 13歳以上
  • 登録:2013/03/02 18:10:10
  • 終了:2013/03/09 18:15:05

ベストアンサー

id:taknt No.1

きゃづみぃ回答回数13539ベストアンサー獲得回数11982013/03/02 18:41:22

ポイント300pt

シートかモジュールに

Sub コピー()
    UserForm1.Label1.Caption = "ファイル保存中です"
    UserForm1.CommandButton1.Visible = False
    UserForm1.CommandButton1.Caption = "OK"
    UserForm1.Show
End Sub

UserForm1を作成し、そこに Label1とCommandButton1を貼りつけます。
そのUserForm1に 以下のソースを記述します。


Private Sub CommandButton1_Click()
    Me.Hide
End Sub

Private Sub UserForm_Activate()
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    DoEvents
    
    バックアップ先 = "D:\backup"
    複写元1 = "C:\example1"
    複写元2 = "C:\example2"
    
    If FSO.FolderExists(バックアップ先 & "\example1") Then
        Call 属性変更(バックアップ先 & "\example1")
        Kill バックアップ先 & "\example1\*.*"
        FSO.DeleteFolder バックアップ先 & "\example1"
    End If
    
    If FSO.FolderExists(バックアップ先 & "\example2") Then
        Call 属性変更(バックアップ先 & "\example2")
        Kill バックアップ先 & "\example2\*.*"
        FSO.DeleteFolder バックアップ先 & "\example2"
    End If
    
    
    MkDir バックアップ先 & "\example1"
    MkDir バックアップ先 & "\example2"
    
    FSO.CopyFolder 複写元1, バックアップ先 & "\example1"
    
    FSO.CopyFolder 複写元2, バックアップ先 & "\example2"
    
    
    UserForm1.Label1.Caption = "ファイル保存完了!"
    UserForm1.CommandButton1.Visible = True
End Sub

Private Sub 属性変更(p As String)
    Dim myFileName As String
    myFileName = Dir$(p & "\*.*", vbDirectory Or vbHidden Or vbSystem)
    Do While myFileName <> ""
        SetAttr p & "\" & myFileName, vbNormal
        myFileName = Dir$
    Loop
End Sub
他2件のコメントを見る
id:taknt

Private Sub CommandButton1_Click()
    Me.Hide
End Sub

Private Sub UserForm_Activate()
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    DoEvents
    
    バックアップ先 = "D:\backup"
    複写元1 = "C:\example1"
    複写元2 = "C:\example2"
    
    If FSO.FolderExists(バックアップ先 & "\example1") Then
        Call 属性変更(バックアップ先 & "\example1")
        FSO.DeleteFolder バックアップ先 & "\example1"
    End If
    
    If FSO.FolderExists(バックアップ先 & "\example2") Then
        Call 属性変更(バックアップ先 & "\example2")
        FSO.DeleteFolder バックアップ先 & "\example2"
    End If
    
    
    MkDir バックアップ先 & "\example1"
    MkDir バックアップ先 & "\example2"
    
    FSO.CopyFolder 複写元1, バックアップ先 & "\example1"
    
    FSO.CopyFolder 複写元2, バックアップ先 & "\example2"
    
    
    UserForm1.Label1.Caption = "ファイル保存完了!"
    UserForm1.CommandButton1.Visible = True
End Sub

Private Sub 属性変更(p As String)
    Dim myFileName As String
    myFileName = Dir$(p & "\*.*", vbDirectory Or vbHidden Or vbSystem)
    Do While myFileName <> ""
        If Not (myFileName = "." Or myFileName = "..") Then
            SetAttr p & "\" & myFileName, vbNormal
            Kill p & "\" & myFileName
        End If
        myFileName = Dir$
    Loop
End Sub
2013/03/08 11:57:45
id:great_pessimist

きゃづみぃさん
いろいろとありがとうございました。
助かりました。

2013/03/17 10:13:02
  • id:Mook
    この手の作業は VBA などよりはタスクスケジューラで定期的にフォルダコピーをするジョブを設定したらどうでしょうか。
    http://www.atmarkit.co.jp/fwin2k/win2ktips/1368taskw7/taskw7.html

    RoboCopy コマンドだったら1行のバッチですむと思います。
    http://www.atmarkit.co.jp/fwin2k/win2ktips/877robomir/robomir.html
  • id:great_pessimist
    Mookさん
    有益なコメントありがとうございました。
    色々な方法があるのですね。
    仕事のメニューがエクセルVBA上で作成されており、そのエクセルファイル上で動かしかったため、
    エクセルVBAでの方法を検討した状況です。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません