エクセル シートのコピーとシート名の問い合わせ

質問

エクセルで日報を作っています。
PC初心者の方がいるので、なるべく簡単なものを作ろうとしています。

まず、各曜日のフォームを６つ作成し、シート1に各曜日のコマンドボタンを置いて、月曜日なら、その曜日のボタンをクリックしてもらうようにしています。
＜例　月曜日＞
Private Sub CommandButton1_Click()
Sheets("月").Copy After:=Sheets(Sheets.Count)
End Sub

で、お聞きしたいのは、シートを挿入する際にダイアログボックスでシート名を問い合わせるものを作りたいのです。
で、調べていたら、下記のようなものが見つかりました。

Private Sub Workbook_NewSheet(ByVal Sh As Object)
Dim strSheet
strSheet = Application.InputBox("シートの名前を入力してください" & vbCr & vbCr & _
"キャンセルでシートの挿入を取り消します")
Select Case strSheet
Case False
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Case Else
Sh.Name = strSheet
End Select
End Sub

別にこれを使わなくてもいいのですが、この２つが合わさったものをつくりたのですが、どうすればいいのでしょうか。

教えてください。

回答No.1

KenKen_SP · ベストアンサー

こんにちは。KenKen_SP です。

ご希望の動作自体は数行のコードで可なのですが、、エラー処理を含
めると結構長いコードになりますねー。しかし、

> PC初心者の方がいるので、なるべく簡単なものを作ろうとしています。

ということですから、エラー処理をしっかり行った方が良いでしょう。
マクロが止まってエラー表示されると混乱が起こりそうです。

Private Sub CommandButton1_Click()

　　Dim strSheet　As String
　　Dim FLAG　　　As Boolean
　　Dim blnCANCEL As Boolean
　　Dim strBACKUP As String
　　Dim DUMMY　　 As String

　　Do
　　　　strSheet = Application.InputBox( _
　　　　　　Prompt:="シートの名前を入力してください" & vbCr & vbCr & _
　　　　　　　　　　"キャンセルでシートの挿入を取り消します", _
　　　　　　Type:=2)
　　　　If UCase$(strSheet) = "FALSE" Then
　　　　　　blnCANCEL = True
　　　　　　Exit Do
　　　　End If
　　　　'ここからエラー処理------------------------------------
　　　　On Error Resume Next
　　　　FLAG = True
　　　　'同名シートチェック
　　　　DUMMY = ThisWorkbook.Sheets(strSheet).Name
　　　　If Err.Number = 0 Then
　　　　　　FLAG = False
　　　　Else
　　　　　　Err.Clear
　　　　　　'シート名に使えない文字がないかチェック
　　　　　　Application.ScreenUpdating = False
　　　　　　With ThisWorkbook.ActiveSheet
　　　　　　　　strBACKUP = .Name
　　　　　　　　.Name = strSheet
　　　　　　　　If Err.Number > 0 Then FLAG = False
　　　　　　　　.Name = strBACKUP
　　　　　　End With
　　　　　　Application.ScreenUpdating = True
　　　　End If
　　　　'シート名判定結果
　　　　If FLAG = False Then
　　　　　　MsgBox "既に同名シートがあるか、シート名として不適切です。", vbCritical
　　　　End If
　　　　On Error GoTo 0
　　Loop Until FLAG

　　'キャンセル判定
　　If blnCANCEL Then Exit Sub

　　'シート追加
　　With ThisWorkbook
　　　　On Error Resume Next
　　　　Application.ScreenUpdating = False
　　　　.Sheets("月").Copy After:=.Sheets(.Sheets.Count)
　　　　If Err.Number > 0 Then
　　　　　　Application.ScreenUpdating = True
　　　　　　MsgBox "コピー元のシートが見つかりません", vbCritical
　　　　　　Exit Sub
　　　　Else
　　　　　　.ActiveSheet.Name = strSheet
　　　　End If
　　　　On Error GoTo 0
　　End With

End Sub

お礼

お答えありがとうございました。
私がやりたいことを全て式にしていただき、大変助かりました。
もう、ばっちりすぎて質問したこちらがびっくりです。
20ポイントしかお礼できないのが残念です。ホントは500点ぐらいお礼したい感じです。
また、お聞きすることがあると思いますが、その時はまたよろしくお願い致します。