Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

3306 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

▼

【63005】古いシートの削除 ヒロ 09/9/30(水) 19:14

【63010】Re:古いシートの削除 kanabun 09/9/30(水) 21:32

【63011】Re:古いシートの削除 kanabun 09/9/30(水) 21:54

【63012】Re:古いシートの削除 ヒロ 09/9/30(水) 22:30


	【63005】古いシートの削除

ヒロ - 09/9/30(水) 19:14 -


	引用なし

	パスワード

データーを入力しているブックを閉じる際にそのシートを他のブックに
バックアップするコードをこちらの質問箱で教えていただいたのですが
シートの枚数がどんどん増えていくので、手動で削除しています。

シート名を日付にしているので、バックアップ時の日付より１０日ぐらい
以前のシートを削除する方法を教えていただけませんでしょうか？
よろしくお願いいたします。

バックアップのコードです。

Sub SheetCopy()
　Dim ws As Worksheet
　Dim dName As String
　Dim blnWs As Boolean '★

　dName = Format(Now(), "yy-mm-dd") '01-02-14

　Application.ScreenUpdating = False
　Sheets("運送DATA").Select
　Range("A2").Select

　If Range("A2").Value = "" Then '★
　　'MsgBox "A2セルに値がありません" '★
　Else
　　Cells.Copy
　
　　Workbooks.Open ThisWorkbook.Path & "\Backup.xls"
　　blnWs = False '★シートが見つからない
　　For Each ws In Worksheets
　　　If ws.Name = dName Then
　　　　blnWs = True '★'シートが見つかった
　　　　ws.Activate '★
　　　　With ActiveSheet
　　　　　.Range("A1").Select
　　　　　.Paste
　　　　　.Range("A2").Select
　　　　End With
　　　　Exit For
　　　End If
　　Next
　
　　If Not blnWs Then '★シートが見つからなかったとき
　　　ActiveWorkbook.Worksheets.Add
　　　ActiveSheet.Name = Format(Now(), "yy-mm-dd") '01-02-14
　　　With ActiveSheet
　　　　.Range("A1").Select
　　　　.Paste
　　　　.Range("A2").Select
　　　End With
　　End If '★
　End If
　ActiveWindow.Zoom = 85
　ActiveWorkbook.Save　　　　　　　　'上書き
　ActiveWorkbook.Close　　　　　　　 '閉じる
　Application.ScreenUpdating = True
End Sub


	【63010】Re:古いシートの削除

kanabun - 09/9/30(水) 21:32 -


	引用なし

	パスワード

▼ヒロさん：

>シートの枚数がどんどん増えていくので、手動で削除しています。
>
>シート名を日付にしているので、バックアップ時の日付より１０日ぐらい
>以前のシートを削除する方法を教えていただけませんでしょうか？

提示コードからできるだけSelectを無くし、
変数を使うようにしてみました。
（検証してませんのでダミーのBookで試してください）

Sub SheetCopy()
　Dim WS1 As Worksheet
　Dim ws2 As Worksheet
　Dim WB2 As Workbook
　Dim dName As String
　Dim RemoveDate As Date　　'この日付以前のシートを削除
　Dim i As Long
　Dim ss As String
　
　dName = Format$(Date, "yy-mm-dd") '01-02-14

　Set WS1 = ThisWorkbook.Worksheets("運送DATA")
　If IsEmpty(WS1.Range("A2").Value) Then　　'▼変更
　　　MsgBox "A2セルに値がありません"
　　　Exit Sub　　　　　　　　　　　　　　　'▼追加
　End If

　On Error Resume Next
　　Set WB2 = Workbooks.Open( _
　　　　　　ThisWorkbook.Path & "\Backup.xls")
　On Error GoTo 0
　If WB2 Is Nothing Then
　　　MsgBox "BackUp.xls ファイルがありません"
　　　Exit Sub
　End If
　
　Application.ScreenUpdating = False
　'本日のシートに転記
　On Error Resume Next
　　Set ws2 = WB2.Worksheets(dName)
　On Error GoTo 0
　If ws2 Is Nothing Then '★シートが見つからなかったとき
　　　Set ws2 = ActiveWorkbook.Worksheets.Add
　　　ws2.Name = dName
　End If
　
　'--------------　古いシートの削除 ---------- 今回追加部分
　Application.DisplayAlerts = False
　RemoveDate = Date - 10　　'★10日前
　On Error Resume Next
　With WB2.Worksheets
　　　For i = .Count To 1 Step -1
　　　　　ss = .Item(i).Name
　　　　　If IsDate(ss) Then
　　　　　　If CDate(ss) <= RemoveDate Then
　　　　　　　　.Item(i).Delete
　　　　　　End If
　　　　　End If
　　　Next
　End With
　On Error GoTo 0
　Application.DisplayAlerts = True
　
　ws2.Activate
　WS1.UsedRange.Copy ws2.Cells(1)　　'▼変更
　ws2.Range("A2").Select
　ActiveWindow.Zoom = 85
　WB2.Save　　　　　　　　'上書き
　WB2.Close　　　　　　　 '閉じる
　
　Application.ScreenUpdating = True
End Sub


	【63011】Re:古いシートの削除

kanabun - 09/9/30(水) 21:54 -


	引用なし

	パスワード

なお、補足的説明ですが、
本日のシートの追加と古い日付のシートの削除とは
必ずこの順番で実行してください。

というのも、仮に対象Bookに
「8/31」「9/01」「9/03」の3つのシートしかなかったばあい、
古いシートの削除処理を先行して実施しますと
Book内のすべてのシートが削除対象となります。が、
Bookから全てのシートを削除することはできないので、
　a) エラーになるか、
　b) On Error Resume Nextを入れているときは
　　削除すべきシートが 1枚のこることになります。

先に本日シートを追加しておけば、全てのシートが削除される
というケースは発生しません。


	【63012】Re:古いシートの削除

ヒロ - 09/9/30(水) 22:30 -


	引用なし

	パスワード

コードを試してみました。
うまくシートを削除でき、ファイルサイズも小さくすることが出来ました。
大変お世話になりました。ありがとう御座います。

シート削除は、シートを追加したときだけ行われるように
します。ありがとう御座いました。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

3306 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free