条件によりシート追加

いつもお世話になっております。
下記のコードですでに同じシートがあれば、
終了としたいのですが、

シートが追加されてしまいます。

Sub Macro()
On Error Resume Next
For i = 2 To 5
Sheets.Add After:=Sheets(Sheets.Count)
If ActiveSheet.Name <> Format(Sheets("MAIN").Cells(i, 1), "m月d日") Then
ActiveSheet.Name = Format(Sheets("MAIN").Cells(i, 1), "m月d日")
Else
Exit Sub
End If
Next
End Sub

質問者からの補足コメント

• 

  めぐみん様　やっばりすごいです
  ありがとうございました。

  No.6の回答に寄せられた補足コメントです。 補足日時：2021/04/09 19:28

No.6 ベストアンサー 回答者： めぐみん_ 回答日時： 2021/04/09 09:27

書き直し。

あと変数の宣言はしましょうね。
基本です。

Sub megu()
Dim myDic As Object
Dim ws As Worksheet, new_ws As Worksheet
Dim r As Range, st As String

Set myDic = CreateObject("Scripting.Dictionary")

For Each ws In Worksheets
myDic.Add ws.Name, ""
Next

With Worksheets("MAIN")
For Each r In .Range("A2", .Cells(Rows.Count, "A").End(xlUp))
st = Format(r.Value, "m月d日")

If Not myDic.Exists(st) Then
Set new_ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
new_ws.Name = st
myDic.Add new_ws.Name, ""
Set new_ws = Nothing
End If

Next
End With

Set myDic = Nothing

End Sub

この回答へのお礼

ご返事遅れて申し訳ありません
ありがとうございました。

お礼日時：2021/04/09 19:23

No.5 回答者： めぐみん_ 回答日時： 2021/04/09 09:02

No.1&2です。

あ～寝ぼけて名前リストのセル値変化を見落としてました・・・すいません忘れて下さい。

No.4 回答者： Qchan1962 回答日時： 2021/04/09 08:47

おはようございます

既に解決されているご質問も拝見いたしましたが、
らしからぬ迷宮に入っているようですが、シートの挿入や名前設定って
結構お決まりのメソッドがあります。
On Error Resume Next　だとエラーが出る時は名前を変える時なので
既にExcelが自動設定した名前のシートが出来てしまいます。
なのでSheets.Addの前で名前が使えるかなどを調べ、処理を飛ばす必要があります。ご質問の場合は終了ですかね。

ただ、サンプルは名前に出来る文字列しかセルに無いようですが、空白セルや/が入っている文字列などが途中にあるとエラーになります。
結構お決まりなので、分かり難いかも知れませんがコードを示します。

Function については、忘れてしまいましたが、どこかで拾ったものです。

Sub Macro1()
Dim r As Range
Dim AtvSheet As Worksheet
Set AtvSheet = ActiveSheet
For Each r In AtvSheet.Range("A2:A5")
If PermitName(r.Text) = False _
Or Not SheetExists(r.Text) Is Nothing Then GoTo nexSh
Sheets.Add(After:=Sheets(Sheets.Count)).Name = r.Text
nexSh:
Next r
AtvSheet.Select
End Sub
'同名チェック
Function SheetExists(ByVal argName As String, _
Optional ByVal wb As Workbook = Nothing) As Object
Dim sht As Object
If wb Is Nothing Then Set wb = ThisWorkbook
For Each sht In wb.Sheets
If StrConv(LCase(sht.Name), vbNarrow) = StrConv(LCase(argName), vbNarrow) Then
Set SheetExists = sht
Exit Function
End If
Next
Set SheetExists = Nothing
End Function
'文字チェック
Function PermitName(ByVal argName As String) As Boolean
PermitName = False
If argName = "" Then Exit Function
If Len(argName) > 31 Then Exit Function
If argName = "履歴" Then Exit Function
If Left(argName, 1) = "'" Then Exit Function
Dim NgChar As Variant
NgChar = Array(vbNullChar, _
":", "\", "/", "?", "*", "[", "]", _
"：", "\", "／", "？", "＊", "［", "］", "＼")
Dim i As Long
For i = 0 To UBound(NgChar)
If InStr(argName, NgChar(i)) > 0 Then
Exit Function
End If
Next
PermitName = True
End Function

ループは、後で改修し易いのでFor Each r In AtvSheet.Range("A2:A5")と
しました。個人的感覚。
Sheets("MAIN")は、実行時のシートをSet AtvSheet = ActiveSheet　としていますので明示されるのが良いと思います。（ActiveSheet部分を変更してください）
ほぼ対応できると思います。ステップ実行で確認してみてください。
＞同じシートがあれば、終了
処理は飛ばしているだけなのでデータ範囲の最後まで処理されます。

この回答へのお礼

ご返事遅れて申し訳ありません
ありがとうございました。
NgChar = Array(vbNullChar, _
":", "\", "/", "?", "*", "[", "]", _
"：", "\", "／", "？", "＊", "［", "］", "＼")これは初めてみました。

お礼日時：2021/04/09 19:24

No.3 回答者： zongai 回答日時： 2021/04/09 08:35

セルの値をシート名2 -いつもお世話になっております。

セルＡ2からＡ31- Excel（エクセル） | 教えて!goo
https://oshiete.goo.ne.jp/qa/12299779.html
↑
ここから加工を続けている感じでしょうか。

作成したマクロだと
①シートを追加する
　（追加されるシートは「Sheet?」という名前）

②シート名の変更処理
　追加したシートの名前がMAINシートのA列に用意したものと…
　　(1)違うなら名前を変更
　　(2)同じなら終了

という流れなです。
追加されるシートは「Sheet?」なので、MAINシートに用意したシート名リストと異なるのは当然です。
なので②-(2)の処理は行われることはありません。

また、追加したシートの名前を変更する際に、既存のシートの名前と重複する場合、②-(1)でエラーになりますが、
On Error Resume Next
で、エラーが出ても処理続行にしてるので、Forループが最後まで実行されます。


なので、

最初に、
①同名のシートの有無を確認
②同名のシートが…
　無ければシートを追加して名前変更
　あれば終了
という流れにします。

Sub Macro()
'　　On Error Resume Next
　　For i = 2 To 5
　　　　CHK = 0
　　　　For j = 1 To Sheets.Count
　　　　　　If Sheets(j).Name = Format(Sheets("MAIN").Cells(i, 1), "m月d日") Then
　　　　　　　　CHK = 1
　　　　　　　　Exit For
　　　　　　End If
　　　　Next
　　　　If CHK = 0 Then
　　　　　　Sheets.Add After:=Sheets(Sheets.Count)
　　　　　　ActiveSheet.Name = Format(Sheets("MAIN").Cells(i, 1), "m月d日")
　　　　Else
　　　　　　Exit For
　　　　End If
　　Next
End Sub

この回答へのお礼

ありがとうございました。

お礼日時：2021/04/09 19:25

No.2 回答者： めぐみん_ 回答日時： 2021/04/09 08:26

No.1です。

＞If Worksheets(i).Name = Format(Sheets("MAIN").Cells(i, 1), "m月d日") Then ch = False

を

If Worksheets(i).Name = Format(Sheets("MAIN").Cells(i, 1), "m月d日") Then ch = False : Exit For

があとが無駄にならず良いかも。

No.1 回答者： めぐみん_ 回答日時： 2021/04/09 08:24

検証してませんが。

まずは同じ名前があるかどうかを調べましょう。

あったらその後は無視。
なかったら作成する。

Sub Macro()
Dim i As Integer, ch As Boolean

ch = True

For i = 2 To 5 ' Worksheets.Count ?
If Worksheets(i).Name = Format(Sheets("MAIN").Cells(i, 1), "m月d日") Then ch = False
Next

If ch Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Format(Sheets("MAIN").Cells(i, 1), "m月d日")
End If

End Sub