こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

まず、各曜日のフォームを6つ作成し、シート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

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

教えてください。

投稿日時 - 2005-11-01 09:24:02

QNo.1749293

すぐに回答ほしいです

質問者が選んだベストアンサー

こんにちは。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

投稿日時 - 2005-11-01 10:38:38

お礼

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

投稿日時 - 2005-11-01 14:32:45

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(1)

あなたにオススメの質問