エクセル マクロでシート名に日付と1から追番をつけ、日付が変わると再び1から始めたいのですが。

左から「名前」、「基本」と2つのシートがあります。
以下のマクロでシート追加ができるのですが、日付が変わっても
シート枚数をカウントしているので、そのまま連続です。

'基本シートの後に追加します
Worksheets.Add After:=Worksheets("基本"), Count:=1

'追加されたシートに名前を付けます
Worksheets(3).Name = Format(Date, "yyyymmdd") & "-" & Worksheets.Count - 2

マクロでシート名に日付と1から追番をつけ、日付が変わると再び1から始めたいのですが 、ここでストップしています。ご教示いただければありがたいです。

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

• お問い合わせの通りです。新しいシートは左から3つめに作成するようにしています。「名前を付けます・・・」では、日付は関数で変わりますが、シートをカウントして付加しているため、日付が変わると「1」に戻すでスタックしています。

    補足日時：2019/06/20 13:35

No.3 回答者： rukaandkaito 回答日時： 2019/06/20 13:45

おやっ？

同一のブック内に複数の日付にまたがるシートがあって、日付が変わるたびにカウンタを１から付け直していきたい
という要望で良かったですよね？
でしたら先ほどのNo.2のコードを最終記載分の２行修正すれば対応出来ているはずですが・・・
何か不都合がありましたか？

No.2 ベストアンサー 回答者： rukaandkaito 回答日時： 2019/06/20 13:19

No.1です

すみません、質問を勘違いしていました
ただ、質問者様の記述だと新規シートは必ず３枚目に来るようになっていますがそれで問題ないですか？一応一番後ろに追加されるパターンでコードを作成してみました
--------------------------------------------------------------------------------
Sub Sample()
　　Dim objSh As Worksheet
　　Dim strDte As String
　　Dim intS As Integer
　　Worksheets.Add After:=Worksheets(Worksheets.Count), Count:=1
　　strDte = Format(Date, "yyyymmdd")
　　intS = 0
　　For Each objSh In Worksheets
　　　　If strDte = Left(objSh.Name, 8) Then
　　　　　　If intS < Int(Mid(objSh.Name, 10, 2)) Then
　　　　　　　　intS = Mid(objSh.Name, 10, 2)
　　　　　　End If
　　　　End If
　　Next
　　intS = intS + 1
　　Worksheets(Worksheets.Count).Name = strDte & "-" & intS
End Sub
--------------------------------------------------------------------------------
もし３枚目を最新ファイルにしたい場合には質問者様の記述の様に変更してください
　　Worksheets.Add After:=Worksheets(Worksheets.Count), Count:=1
を
　　Worksheets.Add After:=Worksheets("基本"), Count:=1
と
　　Worksheets(Worksheets.Count).Name = strDte & "-" & intS
を
　　Worksheets(3).Name = strDte & "-" & intS
です

お試しください

この回答へのお礼

有難うございました。いただいたマクロを試しましたが、望んでいた通りの結果になりました。初心者にはなかなかハードルが高いですね。

お礼日時：2019/06/20 13:52

No.1 回答者： rukaandkaito 回答日時： 2019/06/20 12:08

Worksheets(3)←ここが固定になっていますが

Worksheets(Worksheets.Count)ではいかがでしょう？

この回答へのお礼

早速の回答ありがとうございます。回答いただいたように変更してみましたが、「sheetxx」と追加され、結果はうまくいきませんでした。

お礼日時：2019/06/20 12:32