【EXCEL】別のワークブックにアクティブシートをコピーして挿入したい

Question

別のワークブックにアクティブシートをコピーして挿入したいと思っております。
挿入先に同じ名前のワークシートが存在する時はシートを挿入しない、
という場合は自力で実現できました。

ところが、頑張ってみたのですがシートが存在した場合に上書きする方法がわかりません。
※既存のシートを削除して新規のシートを挿入する

すいませんが詳しい方、説明の上手な方、直接、コードで説明できる方、
お手数ですが教えて下さい。よろしくお願いします。


詳細～シートの挿入時に必要な機能、etc.

1)挿入先に同じ名前のシートがある場合、既存のシートを削除して新規のシートを挿入
2)挿入先のワークブックが開いている場合
※「開いていているための挿入出来ない」のエラーメッセージの表示

3)ユーザーフォームのボタンから実行します。
動作が分割される場合はボタン一発で実行できるものでお願いします。
→Callの利用は無理だと思います。
4)挿入前にシート名に「No」の記載がされているか
「はい」、「いいえ」を確認するメッセージを入れたい。
※マクロで「No」を追加するのはなしです。
今後も社内ルールの確認用のメッセージに使う予定ですので。

5)A列とH列に全角文字があれば半角に変換に変換したシートを挿入する
6)便宜上、ワークブックの名前、フォルダーは以下の通りでお願いします
ワークブックの名前
コピー元：コピー元.xlsm
コピー先：挿入先.xlsm
「挿入先.xlsm」のフォルダーはCドライブの
「A」フォルダーの中ということでお願いします。

追記
こちらも参考にトライしてみました、ご参考にどうぞ
↓
https://oshiete.goo.ne.jp/qa/9476111.html

※文字数がオーバーするので、前述の
「挿入先に同じ名前のワークシートが存在する時は、シートを挿入しない場合」
のコードは記載しませんでした。

必要でしたら別途質問を立てて、そちらに貼り付けますので、
お気軽にリクエストしてください。

すいませんがよろしくお願いします。

tatsu99 · Accepted Answer

No1です。
既にNo2の方が回答されてますので、参考までに。コマンドボタン１をクリックした想定です。
--------------------------------------
Option Explicit

Private Sub CommandButton1_Click()
    Const FolderName As String = "c:\A"
    Const TrgBookName As String = "挿入先.xlsm"
    Dim trgBook As Workbook
    Dim srcBookName As String
    Dim srcSheetName As String
    Dim srcBook As Workbook
    Dim wBook As Workbook
    Dim wSheet As Worksheet
    Set srcBook = Application.ActiveWorkbook
    srcBookName = Application.ActiveWorkbook.Name
    srcSheetName = ActiveSheet.Name
    If MsgBox("シート名は[" & srcSheetName & "]です。" & vbLf & "シート名にNoが記載されていますか？", vbYesNo) <> vbYes Then
        Exit Sub
    End If
    Call ZenToHan("A")  'A列を全角から半角変換
    Call ZenToHan("H")  'H列を全角から半角変換
    '挿入先のBookが開いているかチェックする
    For Each wBook In Workbooks
        If UCase(wBook.Name) = UCase(TrgBookName) Then
            MsgBox (TrgBookName & "は既に開いています。閉じて下さい。")
            Exit Sub
        End If
    Next
    '挿入先のBookが存在するかチェックする
    If Dir(FolderName & "\" & TrgBookName) = "" Then
        MsgBox (FolderName & "\" & TrgBookName & "が存在しません。")
        Exit Sub
    End If
    'Bookオープン
    Set trgBook = Workbooks.Open(Filename:=FolderName & "\" & TrgBookName)
    If trgBook.ReadOnly = True Then
        trgBook.Close
        MsgBox (TrgBookName & "は既に使用されています。")
        Exit Sub
    End If
    '挿入先に該当シートが存在すれば削除する
    For Each wSheet In Worksheets
        If UCase(wSheet.Name) = UCase(srcSheetName) Then
            Application.DisplayAlerts = False
            Worksheets(wSheet.Name).Delete
            Application.DisplayAlerts = True
            Exit For
        End If
    Next
    'シートコピー
    Workbooks(srcBookName).Worksheets(srcSheetName).Copy after:=Worksheets(Worksheets.Count)
    'Bookクローズ
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    '元のBook,Shhetをアクティブに設定
    Workbooks(srcBookName).Activate
    Worksheets(srcSheetName).Activate
    MsgBox (srcSheetName & "のコピー完了")
End Sub
'全角から半角へ変換する
Private Sub ZenToHan(ByVal col As String)
    Dim row, maxrow As Long
    maxrow = Cells(Rows.Count, col).End(xlUp).row '最終行を求める
    For row = 6 To maxrow
        Cells(row, col).Value = StrConv(Cells(row, col).Value, vbNarrow)
    Next
End Sub
----------------------------

ママチャリ · Answer

No2です。わざわざ開けておいていただいて恐縮です。
「開いているための挿入出来ない」のメッセージは、他の人が開いている場合を想定していて、自分で開いている場合を想定していませんでした。tatsu99さんはそこまで考えていたようで、さすがですね！！

しかし、挿入先ブックって、担当者に公開しているのですか？てっきり、今回のマクロを使うことにより、その存在を担当者から秘匿するものだと思っていました。よって、担当者自身が開いていることは想定しませんでした。
想定していたのは、「今回のマクロを複数の担当者が同時に実行した。」もしくは、「管理者使（ZZ-TOPさん？）が、挿入先ブックで何らかの作業を行っている」等のケースのみです。

どちらにしても、tatsu99さんの回答が完璧なので、この質問もクローズして頂いて結構です。また、追加分の質問も忘れずにクローズしてくださいね。

tatsu99 · Answer

No3です。
私が提示したソースは、コピー元のＡ列とＨ列を半角に変換し、それをコピーしています。
それが都合悪い場合は（コピー元のデータを変えたくない場合）、その旨補足してください。

ママチャリ · Answer

全角→半角変換は、漢字や平仮名など変換できないケースもありますが、そこは問題ないですか？

Sub sample()
    Dim wsFrom As Worksheet
    Dim wbTo As Workbook
    Dim r As Range
    Set wsFrom = ActiveSheet
    If MsgBox("シート名に「No」の記載がされているか？", vbYesNo) = vbNo Then
        Exit Sub
    End If
    Set wbTo = Workbooks.Open(Filename:="C:\A\挿入先.xlsm")
    If wbTo.ReadOnly Then
        MsgBox "開いていているための挿入出来ない"
        wbTo.Close
        Exit Sub
    End If
    For Each r In Intersect(wsFrom.UsedRange, wsFrom.Range("A:A,H:H"))
        r.Value = StrConv(r.Value, vbNarrow)
    Next r
    Application.DisplayAlerts = False
    On Error Resume Next
    wbTo.Sheets(wsFrom.Name).Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    wsFrom.Copy Before:=wbTo.Sheets(1)
    wbTo.Close SaveChanges:=True
End Sub

tatsu99 · Answer

補足要求です。

質問１
>4)挿入前にシート名に「No」の記載がされているか
>「はい」、「いいえ」を確認するメッセージを入れたい。
これは、挿入対象となるシートのシート名（アクティブシートのシート名）に「No」が含まれているかという意味でしょうか。
又、[No]が含まれているか否かは、下記の全ケース、含まれていると考えて良いですか。
NoXXX ・・・前方一致
ＸXXNo  ・・・後方一致
ＸXXNoYY・・・部分一致
No　　・・・完全一致
（ＸＸＸ、ＹＹは任意の文字）

Noの文字であるとみなすのは半角のNo(大文字のN、小文字のo）のみですか。
no(半角小文字のno)、NO(半角大文字のNO)、Ｎｏ（全角のNo）等も[No]の文字であるとみなすのでしょうか。

[No]の文字がアクティブシートのシート名に含まれない場合、確認メッセージを表示し、
応答が「はい」であればコピーを行い、「いいえ」であれば、コピーを行わない。・・・と理解しましたが、あってますか。
（[No]の文字がアクティブシートのシート名に含まれる場合は、確認メッセージを表示せず、コピーを行います）

質問２
>5)A列とH列に全角文字があれば半角に変換に変換したシートを挿入する
これは、A列とH列の全行をチェックするのでしょうか。（１行目を含む）
それとも１行目はチェック対象外でしょうか。（１行目は見出し行なのでチェックしない）

質問３
>動作が分割される場合はボタン一発で実行できるものでお願いします。
>→Callの利用は無理だと思います。
これは、サブプロシージャをつくるなという意味であれば、間違っています。
サブプロシージャを作ってもボタン一発で実行可能です。
それとも「→Callの利用は無理」とは、他の意味でしょうか。

サブプロシージャがあっても、ボタン一発で実行可能です。
Private Sub CommandButton1_Click()・・・本体
・・・
call サブプロシージャ
・・・
end sub
private sub サブプロシージャ
end sub

今回、サブプロシージャはつくることはないと思いますが念の為。
（サブのFunctionプロシージャは全角文字があるか否かの判定で作る予定です）

【EXCEL】別のワークブックにアクティブシートをコピーして挿入したい

No1です。

No2です。

No3です。

全角→半角変換は、漢字や平仮名など変換できないケースもありますが、そこは問題ないですか？

補足要求です。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング