| |
▼ヒロ さん：
>シートの枚数がどんどん増えていくので、手動で削除しています。
>
>シート名を日付にしているので、バックアップ時の日付より１０日ぐらい
>以前のシートを削除する方法を教えていただけませんでしょうか？
提示コードからできるだけ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
|
|
kanabun
- 09/9/30(水) 21:32 -
