【VBA】シート名が重複したら連番になるワークシートの新規作成【改】
※2018/11/10追記
この記事が参考になったか、記事下のアンケートにご協力ください。
Excelマクロ、VBAでワークシートを作成するときにこのようなエラーが生じた経験はありませんか?
この名前は既に使われています。別の名前を入力してください。
とか
実行時エラー '1004' : アプリケーション定義またはオブジェクト定義のエラーです。
とか。これは新規作成するシート名が既に存在している場合に生じます。
いつだかに、Excelのワークシート名が重複した際に連番をふるVBAを公開しましたが、どうやらエラーの処理が完全ではなかったので修正しました。
本題
Excelの仕様上、アルファベットの半角全角やひらがな、カタカナの全角半角の区別がないようで、”とうかいニッキ”や”トウカイにっき”は同じシート名として判定されるようです。
従ってこれらの例外が生じた際の回避をしなければなりません。
このコードでは英字はすべて全角、ひらがなカタカナは全角に直して全てひらがなに変換することで判定漏れが無いようにしました。
これでよっぽどのことがない限りはエラーが生じないと思います。
ただ、このプログラムが回っているときに、セルの編集をしていると新規Sheetは生成できずにエラーとなります。これはExcelの仕様なのでどうしようもありません。てかマクロを実行しているときにセルの編集はあまりしないほうがいいです。
以下のコードをコピペしてプロシージャ”WS”を実行すればいいです。
実際の実装ではCreateNewWorksheet( String )をCallして使用してください。
Option Explicit 'WorkSheet名を与えることでワークシートを新規作成 '重複したworksheetがある場合、(1), (2), ...と連番になる。 '呼び出し側には作成したワークシート名(ByRef)を返す。 Sub CreateNewWorksheet(ByRef SheetName As String) Dim i As Long, j As Long Dim rc As String, tmpSN As String Dim NewMode As Boolean Dim CworkS As Boolean 'Loopの終了判定(Checkworksheet) CworkS = True tmpSN = SheetName '新しいグラフ描画用シートの作成 Do While CworkS CworkS = WorkSheetCheck(tmpSN) '重複したworksheetがある場合、(1), (2), ...と連番をつけて, '更に重複が無いか調べてない場合はWorksheet名として適用する。 j = j + 1 '連番用の変数 If j = 100 Then MsgBox ("カウントが発散してます。") End End If If CworkS Then '重複した場合 If j = 1 Then rc = MsgBox(SheetName & vbCrLf & "はすでに""開いています" & vbCrLf & "新しく読み込みますか?", _ vbExclamation + vbYesNo) End If If rc = vbYes Then 'worksheet新規作成モードに切り替え NewMode = True 'シート名の再設定 tmpSN = SheetName & "(" & j & ")" Else MsgBox "終了します" Exit Sub End If End If Loop 'ワークシートを最後尾に新規作成し、指定したファイル名にする。 If NewMode Then With Worksheets.Add(after:=Worksheets(Worksheets.Count)) .Name = tmpSN SheetName = tmpSN End With Else With Worksheets.Add(after:=Worksheets(Worksheets.Count)) .Name = SheetName End With End If End Sub '重複したWorksheetが有るかチェックする。 '引数;検索するシート名 CheckSheets '戻り値; 重複検出=>WSC=True, 重複なし=>WSC=False Function WorkSheetCheck(ByVal CheckSheets) As Boolean Dim i As Long WorkSheetCheck = False Dim tmpShChar As String, tmpChar As String For i = 1 To Worksheets.Count 'シート名は大文字小文字区別されないのでここで、全て小文字に変換しておく。 tmpShChar = LCase(Worksheets(i).Name) tmpChar = LCase(CheckSheets) tmpChar = StrConv(tmpChar, vbWide) tmpChar = StrConv(tmpChar, vbHiragana) tmpShChar = StrConv(tmpShChar, vbWide) tmpShChar = StrConv(tmpShChar, vbHiragana) If tmpShChar = tmpChar Then WorkSheetCheck = True Exit Function End If Next End Function
Sub WS() Dim AdShName As String AdShName = "Sheet1" '新規作成したいワークシート名を書きます。 Call CreateNewWorksheet(AdShName) Debug.Print test End Sub