Excel2000 VBAで新規シート名を他のシート名と重ならないようにつけるには？

質問

始めまして。早速ですが、今頭を抱え込んでいる私の悩みを聞いて下さい。

シート名を追加するプログラムで、「シートを追加」というボタンを押すと、
Inputboxを表示し、そこに任意の番号（"見積書1"や"請求書1"の数字部分）を入力して、その番号をシート名として取得すると同時に、シートを追加するようにしたいのです。

その過程で、新しいシートの名前をつける際に、同じブック内に既に存在する複数
のシート名と照らし合わせて、もし、既存の番号と同じ番号をInputBoxに入れたときには、「他の番号を入力してください」と再度InputBoxを表示させたいのです。
そして、シート名がブック内に同じものがない場合にのみ、シートを追加するというものです。

VBAを使うより、手動ですれば？という考えももちろん解決方法の一つかとは思いますが、何分Excelを始めて使う年老いた父のために、少しでも簡単に操作できるようにという思いから質問させて頂いております。

どうぞよろしくお願いいたします。

回答No.3

nishi6 · ベストアンサー

シートの番号のみを入力します。
そのために、番号を除いた部分を登録しておきます。下では wsPattName = "見積書" です。

また、番号入力すると、1→2→4と入力するかもしれません。
番号入力しないで、既存番号+1を自動で付けるのが一番『親切』？　SheetNameChange2 でそれを行っています。

標準モジュールに貼り付けます。

Sub SheetNameChange()
　　Dim inputCheck As Boolean '入力は正しいか
　　Dim wsNo As Variant 'ワークシート番号
　　Dim ws As Worksheet 'ワークシート
　　Dim wsPattName As String 'ワークシートに共通な名前部分
　　Dim myMsg As String 'メッセージ

　　wsPattName = "見積書" '*** 事前に登録しておきます! ***
　　Const myMsg0 = "ワークシートの番号を入力して下さい": myMsg = myMsg0
　　Do
　　　　wsNo = InputBox(myMsg)
　　　　If wsNo = "" Then Exit Sub 'キャンセル
　　　　'重複をチェック
　　　　inputCheck = True
　　　　For Each ws In Worksheets
　　　　　　If ws.Name = wsPattName & wsNo Then
　　　　　　　　inputCheck = False
　　　　　　End If
　　　　Next
　　　　myMsg = "番号が重複しました。" & vbCrLf & myMsg0
　　Loop Until inputCheck = True

　　'シートを追加
　　Dim actSht As String '今アクティブなシート名
　　actSht = ActiveSheet.Name
　　Worksheets.Add.Move AFTER:=Worksheets(Worksheets.Count)
　　ActiveSheet.Name = wsPattName & wsNo
　　Worksheets(actSht).Activate
End Sub

'＜参考＞
Sub SheetNameChange2()
　　Dim wsNo As Variant 'ワークシート番号
　　Dim wsNoMax As Integer '最大のワークシート番号
　　Dim ws As Worksheet 'ワークシート
　　Dim wsPattName As String 'ワークシートに共通な名前部分

　　wsPattName = "見積書" '*** 事前に登録しておきます! ***
　　For Each ws In Worksheets
　　　　If IsNumeric(Application.Substitute(ws.Name, wsPattName, "")) Then
　　　　　　wsNo = Val(Application.Substitute(ws.Name, wsPattName, ""))
　　　　End If
　　　　If wsNoMax < wsNo Then wsNoMax = wsNo
　　Next

　　'シートを追加
　　Dim actSht As String '今アクティブなシート名
　　actSht = ActiveSheet.Name
　　Worksheets.Add.Move AFTER:=Worksheets(Worksheets.Count)
　　ActiveSheet.Name = wsPattName & (wsNoMax + 1)
　　Worksheets(actSht).Activate
End Sub

お礼

nishi6さん、サンプルを2通り作成下さいましてどうも有難うございます。
早速、両方のプログラムを試してみました。

nishi6さんのおっしゃるように、SheetNameChange2だと、びっくりするほど
簡単にシートを追加することができ、かつ合理的だと思いました。

また、『親切』という思いやりの気持ちまでプログラムに組み込まれているような気さえしました！

今後は、その気持ちを忘れずにプログラムを書いてみたいと思います。

回答No.2

kazuhiko5681

初めまして。サンプルマクロを作ってみました。参考にしてみて下さい。

Sub Test()

Dim myIpb As Variant
Dim myWsn As Worksheet

myIpb = Application.InputBox("シート名を入力して下さい。", "シート名入力")
If myIpb = False Then Exit Sub
If myIpb = "" Then
Do
myIpb = Application.InputBox("シート名を入力して下さい。", "シート名入力")
If myIpb = False Then Exit Sub
Loop While myIpb = ""
End If

For Each myWsn In Worksheets
If myWsn.Name = myIpb Then
myIpb = Application.InputBox("指定したシート名は、入力済みです。変更して下さい。", "シート名入力")
If myIpb = False Then Exit Sub
If myIpb = "" Then
Do
myIpb = Application.InputBox("シート名を入力して下さい。", "シート名入力")
If myIpb = False Then Exit Sub
Loop While myIpb = ""
End If
End If
Next myWsn

Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = myIpb

End Sub

もし、操作しなかったり不都合・ご不明な点がありましたらご遠慮なくお知らせ下さい。私でよろしければ、あなた様のおやりになりたいことが実現するまでご一緒に考えていきたいと思います。

お礼

わざわざ、サンプルまで作成下り有難うございます。
プログラムというのは、同じ動作でも、いろいろな書き方ができるんですね。
私には思いもつきませんでした。VBAに対してますます興味を持ちました。

このプログラムでスマートに実現することができました。
今後はプログラムの書き方を工夫するようにしたいと思いました。

回答No.1

Te-Sho

For Eachを使ってworksheetsコレクション内をループさせることが出来ます。
その時に取得したworksheetオブジェクトのnameプロパティを参照すれば名前のチェックは出来るはずです。

たとえば

Dim chk_sheet as worksheet
For Each chk_sheet In worksheets
If chk_sheet.name = strInputName then
msgbox "同名ファイルが存在します"
exit For
end if
Next

ですね。

詳しくはhelpで"for each","worksheetsコレクション","nameプロパティ"を参照してみてください。

お礼

早速の回答下さり有難うございます。
Te-Shoさんのおっしゃるとおり、for eachでW各Worksheets名を参照させる方法で
試行錯誤していたところでした。自信がなかったので、その旨書きませんでした。
教えていただきました方法で実現することができました。