| |
こんにちは。かみちゃん です。
>シート名をその日の日付にしてバックアップし、同じ日の
>シート名がある場合はシートを上書き、無いときは新規に
>シートを追加してデータをコピーする
動作確認はしていませんが、以下のようにしてはいかがでしょうか？
（★の行を追加）
提示されたコードでは、シートが見つかっても見つからなくても、For 〜 Next
の後に、シート追加・名前変更が行なわれています。
そのため、シートが見つからなかったときだけ処理するように処理分岐を加えます。
Sub SheetCopy2()
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") = "" Then
' ElseIf Range("A2") <> "" Then
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
ActiveWorkbook.Save '上書き
ActiveWorkbook.Close '閉じる
Application.ScreenUpdating = True
End Sub
なお、別案として、以下のようにしてもいいかと思います。
Sub SheetCopy3()
Dim ws As Worksheet
Dim dName As String
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"
Set ws = Nothing
On Error Resume Next
Set ws = Worksheets(dName)
On Error GoTo 0
If ws Is Nothing Then 'シートが見つからなかった場合
Set ws = ActiveWorkbook.Worksheets.Add
ws.Name = dName
End If
ws.Activate
Range("A1").Select
ActiveSheet.Paste
Range("A2").Select
End If
ActiveWorkbook.Save '上書き
ActiveWorkbook.Close '閉じる
Application.ScreenUpdating = True
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 08/11/24(月) 20:22 -
