人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセル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で単純にフォルダの上書きバックアップが出来ない。

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

●質問者: great_pessimist
●カテゴリ:コンピュータ インターネット
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● きゃづみぃ
●300ポイント ベストアンサー

シートかモジュールに

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

great_pessimistさんのコメント
きゃづみぃさん ご回答頂きありがとうございました。また、返信遅くなって申し訳ありませんでした。 実施ししたところ確かにバックアップできましたが、二回目のバックアップをしたところ、 「実行時エラー53: ファイルが見つかりません。」 のメッセージが出で、デバッグ(D)をクリックすると、 Kill バックアップ先 & "\example2\*.*" が黄色く表示されます。 もし改善方法があれば教えてください。

きゃづみぃさんのコメント
フォルダだけあってファイルが存在しない場合を 考慮しないと いけないということですね。

きゃづみぃさんのコメント
>|vb| 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 ||<

great_pessimistさんのコメント
きゃづみぃさん いろいろとありがとうございました。 助かりました。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ