セルの値から新規にシートを作成する。ただし既にセルの値と同じ名前のシートがある場合には作成しない。

Question

ＶＢＡ初心者です。
今は以下のような作業をしたいと思っています。

【作業】
ブックの中には
"入力"シート・・Ａ１セルからＡ１０セルには　10,20,30,40の数字をランダムに入力
"１０"シート
”３０”シート
上記３つのシートが存在します。

入力シートのＡ１セルからＡ１０セルを確認して、その数字がないものについて
その数字をシートの名前にして、シートを新規に作成する。

結果としては”２０”シートと”４０”シートが新規に作成される。

【エラー】
実行時エラーとして
「既に名前が使用されています。別の名前を入力してください。」がでます。

【コード】
Sub Sheet作成()

Dim i
Dim s As Worksheet
Dim find_name As String
Dim flg As Boolean

For i = 1 To 10

  find_name = Worksheets("入力").Cells(i, 1)

  flg = False

For Each s In ThisWorkbook.Worksheets

    If s.Name <> find_name Then
        flg = True
        GoTo L1
    End If
Next

L1:

If flg = True Then

    Worksheets.Add after:=Worksheets(Worksheets.Count)
    Worksheets(Worksheets.Count).Name = Worksheets("入力").Cells(i, 1)
End If

Next i
End Sub

どのようにしたらいいかまったくわかりません。
どなたか教えていただけないでしょうか？

Answer 1

数値か文字列かについては、
Dim find_name As Stringと文字列として宣言しているので、
find_name = Worksheets("入力").Cells(i, 1)と代入したときに文字列に暗黙の型変換されるので問題ないです。

ロジックが間違っています。
全てのシート名とセルの値を比較して一つでも異なる名前があったらシートを新規作成するというロジックになっています。
そうではなくて、
全てのシート名とセルの値を比較して一つでも同じ名前があったらシートを新規作成しないというロジックにしないと。

呈示のコードを最小限の修正で済ますなら、

Sub Sheet作成()
    Dim i As Long
    Dim s As Worksheet
    Dim find_name As String
    Dim flg As Boolean

    For i = 1 To 10

        find_name = Worksheets("入力").Cells(i, 1)

        flg = True

        For Each s In ThisWorkbook.Worksheets

            If s.Name = find_name Then
                flg = False
                Exit For
            End If
        Next

        If flg = True Then

            Worksheets.Add after:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = Worksheets("入力").Cells(i, 1)
        End If

    Next i
End Sub

別案

シートの存在チェックは他でも使えそうなので関数にします。
ループですべてのシート名をチェックしてもいいのですがシート数が多いと重くなりますので、例外処理で存在チェックします。（シートにアクセスしてエラーがでたら存在しない）

Sub Sheet作成2()
    Dim r As Range
    For Each r In Worksheets("入力").Range("A1:A10")
       If Not SheetExists(r.Text) Then
           Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = r.Text
        End If
    Next
End Sub

'シートの存在チェック関数
'指定した名前のシートが存在したらTrue、しなかったらFalseを返す
Function SheetExists(SheetName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets(SheetName)
    On Error GoTo 0
    SheetExists = Not (ws Is Nothing)
End Function

Comments

[air8]

回答ありがとうございます。
そもそものロジックの考え方が悪いことには気づかされました。
私のコードを生かしていただいたものを修正すると、エラーとして、また「既に名前が使用されています。別の名前を入力してください。」がでます。
入力シートの１行目には”２０”が入っていて新規に”２０”のシートが作成されますが、入力シートの２行目にも”２０”が入っており、シートは作成されますが、エラーがでてシートの名前が変更されません。

別案の関数にして実行するパターンも試させていただきました。
すごい！感動しました。まだ自分で関数を定義するところまではいけていませんが、今後の参考にさせてください。

[hatena19]

> エラーがでてシートの名前が変更されません。

当方のサンプルではエラーは出ません。コードを写し間違えてませんか。

Answer 2

こんにちはこんばんは。よろしくおねがいいたします。
これ、私が思うに、A列には”数値”が入ってて、いっぽうシート名は”文字列”なので、
単純に比較することができなくて失敗しているのかな？と思いました。

そこでCStrで変換してから比較するようにしてみました。
（ちなみに、Str()では、正の数値を変換するとアタマに半角空白ができるそうです。なのでここではそれは使えないのでCStr()にしました）

そうして作ってみたのが、以下のとおりです。

Option Explicit

Sub InspectAndCreateNewSheet()
'"入力"シートのA列を上から順にサーチして、
'その値の名前と一致するシートがないとき、新規作成する

Dim SearchSheet As Worksheet
Set SearchSheet = ThisWorkbook.Worksheets("入力")

Dim i As Long
Dim r As Range
Dim flag As Boolean

SearchSheet.Select
For Each r In Range("A1", Range("A1").End(xlDown))
flag = False
        For i = 1 To Worksheets.Count
                If Worksheets(i).Name = CStr(r.Value) Then
                flag = True
                End If
        Next i
        If flag = False Then
                Worksheets.Add.Name = CStr(r.Value)
        End If
Next r
End Sub

書きっぷりはちょっと変わりましたが、基本的にあなたの試みていることと同じです。

いかがでしょうか？

Comments

[air8]

ご回答いただきありがとうございます。
実行してみたら私がやりたいと思っていた結果とおりになりました。
とてもわかりやすく、今後の考え方にも生かせそうです。
本当にありがとうございます。

Answer 3

んと、

If flg = True Then

ここが、
あれば（True)何もしない
無ければ(False)新規シート挿入
なので、

If flg = false Then

ですかね。。。。

僕ならこう書くかな。。。

Sub Sheet作成()
    Dim i
    Dim s As Worksheet
    Dim find_name As String

    For i = 1 To 10
        find_name = Worksheets("入力").Cells(i, 1)
        For Each s In ThisWorkbook.Worksheets
            If s.Name <> find_name Then
                Exit For
            End If
        Next

        If s Is Nothing Then
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = find_name
        End If
    Next i
End Sub

もう少し真面目に考えたら、こうかな。
（ついでに並び順もリスト順に並べ替えしてみました＾＾；）

Option Explicit

Sub test()
    Dim wsh As Worksheet
    Dim rngList As Range
    Dim c As Range
    Dim sName As String
    Dim ix As Long
    
    Set rngList = Worksheets("入力").Range("A1:A10")
    ix = 1
    For Each c In rngList
        sName = c.Value
        If ChkName(sName) Then
            On Error GoTo ErrHandler
            Set wsh = Worksheets(sName)
            On Error GoTo 0
            If wsh.Index <> ix + 1 Then wsh.Move after:=Worksheets(ix)
            ix = ix + 1
        Else
            sName = IIf(Len(sName), sName, "空白セル")
            MsgBox c.Address(False, False) & ":" & sName & " NG! スキップします。"
        End If
    Next

    Exit Sub
    
ErrHandler:
    With Worksheets
        .Add(after:=.Item(ix)).Name = sName
    End With
    Resume
End Sub

Function ChkName(ByVal s As String) As Boolean
    Dim v
    
    Select Case Len(s)
        Case 1 To 31
            For Each v In Split(":,\,/,?,*,[,]", ",")
                If InStr(s, v) Then Exit Function
            Next
        Case Else
            Exit Function
    End Select
    ChkName = True
End Function

参考になれば。
※バグがあるかも知れませんので自己責任で。
ちゃんとしようと思ったら何度見直してもきりがない＞＜