Excel VBA質問箱 IV

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

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


22983 / 76738 ←次へ | 前へ→

【59126】Re:シートコピーの上書き
発言  かみちゃん E-MAIL  - 08/11/29(土) 22:00 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>シート名をその日の日付にしてバックアップし、同じ日の
>シート名がある場合はシートを上書き、無いときは新規に
>シートを追加してデータをコピーする

動作確認はしていませんが、以下のようにしてはいかがでしょうか?
(★の行を追加)

提示されたコードでは、シートが見つかっても見つからなくても、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

0 hits

【59042】シートコピーの上書き マイキー 08/11/24(月) 20:14 質問
【59043】Re:シートコピーの上書き かみちゃん 08/11/24(月) 20:22 発言
【59044】Re:シートコピーの上書き マイキー 08/11/24(月) 20:26 発言
【59045】Re:シートコピーの上書き かみちゃん 08/11/24(月) 20:31 発言
【59046】Re:シートコピーの上書き マイキー 08/11/24(月) 20:46 お礼
【59125】Re:シートコピーの上書き マイキー 08/11/29(土) 21:38 質問
【59126】Re:シートコピーの上書き かみちゃん 08/11/29(土) 22:00 発言
【59127】Re:シートコピーの上書き マイキー 08/11/29(土) 22:22 お礼

22983 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free