Excel VBA質問箱 IV

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

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


3973 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【59042】シートコピーの上書き
質問  マイキー  - 08/11/24(月) 20:14 -

引用なし
パスワード
   データを入力しているシートだけバックアップのため
コピーをとることを考え、こちらの投稿を参考に
以下のコードにてバックアップをとることが出来るようになりましたが、
このコードを実行する度に、sheet1(2) sheet1(1) sheet1と言うように
シートが増えていきます。シートを増やさずに上書きするようにするか
ある程度の枚数で以前のシートを削除するような方法は無いでしょうか?
よろしくお願いいたします。

Sub SheetCopy()
 Application.ScreenUpdating = False
 Sheets("sheet1").Copy

 With ActiveSheet
  'コピー先のブックオープン
  'Workbooks.Open ThisWorkbook.Path & "\Backup.xls"'(同じフォルダに置く場合)
  Workbooks.Open Filename:="C:\Users\xxx\Documents\Backup.xls"  '(パスを指定する場合)
  .Move Before:=Workbooks("Backup.xls").Sheets(1)  'オープンしたブックへシートのコピー
 End With
 ActiveWorkbook.Save 
 ActiveWorkbook.Close 
 Application.ScreenUpdating = True
End Sub

【59043】Re:シートコピーの上書き
発言  かみちゃん E-MAIL  - 08/11/24(月) 20:22 -

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

>データを入力しているシートだけバックアップのため
>コピーをとることを考え、こちらの投稿を参考に
>以下のコードにてバックアップをとることが出来るようになりましたが、

Sheet1をCopyしたいのですか?
ActiveSheetをMoveしたいのですか?
シート自体をコピーしたり移動したりするのではなく、シートのセル全体を
バックアップ用のシートにコピーすればいいのではないでしょうか?

【59044】Re:シートコピーの上書き
発言  マイキー  - 08/11/24(月) 20:26 -

引用なし
パスワード
   ▼かみちゃん さん:
すみません。
sheet1を別のブックにコピーしたいだけです。

【59045】Re:シートコピーの上書き
発言  かみちゃん E-MAIL  - 08/11/24(月) 20:31 -

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

>sheet1を別のブックにコピーしたいだけ

それであれば、
Sheets("sheet1").Copy
だけで新規ブックにコピーできるのですが、それではいけないのですか?

その新規ブックを Backup.xls という名前で保存することではいけないのですか?

> sheet1(2) sheet1(1) sheet1と言うように
> シートが増えていきます。

これは、既存ブックにコピーしようとするからそのようになります。

その場合は、シートをコピーするのではなく、
シートのセル全体をBAckup.xlsのシートに貼り付ければいいのではないでしょうか?

【59046】Re:シートコピーの上書き
お礼  マイキー  - 08/11/24(月) 20:46 -

引用なし
パスワード
   そうですね。シートのデータの部分だけを
別ブックのシートに貼り付けることにします。
ありがとうございました。

【59125】Re:シートコピーの上書き
質問  マイキー  - 08/11/29(土) 21:38 -

引用なし
パスワード
   ▼かみちゃん さん:
申し訳ありません。再度質問をお願いいたします。
シート名をその日の日付にしてバックアップし、同じ日の
シート名がある場合はシートを上書き、無いときは新規に
シートを追加してデータをコピーするように考えたのですが
For Eachのところで同じ日付のシートを見つけることが出来ないようで
同じ日付のシートがあっても上書きされず、同じ名前のシートを
作れませんとエラーが起きてしまいます。
申し訳ありませんが、よろしくお願いいたします。

Sub SheetCopy()
  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") = "" Then
  
  ElseIf Range("A2") <> "" Then
    Cells.Copy

    Workbooks.Open ThisWorkbook.Path & "\Backup.xls"
  
    For Each ws In Worksheets
      If ws.Name = dName Then
        With ActiveSheet
           .Range("A1").Select
           .Paste
           .Range("A2").Select
          End With
    Exit For
    End If

    Next

    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
  
  ActiveWorkbook.Save        '上書き
  ActiveWorkbook.Close        '閉じる
  Application.ScreenUpdating = True

End Sub

【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

【59127】Re:シートコピーの上書き
お礼  マイキー  - 08/11/29(土) 22:22 -

引用なし
パスワード
   ▼かみちゃん さん:
ありがとうございます。おかげでうまくいきました。
Copy2もCopy3も同様の結果を得ることが出来ました。
ありがとうございました。

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