【ExcelVBA】重複しないよう連番付きでシート名を設定する

新規にシートを追加したときなど、セルの値を使ってシート名を機械的につけるマクロを組むこともよくあります。

Worksheets.Add
ActiveSheet.Name = Worksheets("売上データ").Range("A1")

みたいなイメージでしょうか。

しかし、このシートの名称設定は、すでに使われているシート名を指定するとエラーになってしまいます。

重複したシート名

こんな風に勝手になってくれたらいいんですけどね。
残念ながらこれを自動ではやってくれません。

この「シート名が重複した場合は連番をつける」方法ですが、
まずはコーディング時間のコスパが良い解決策がこちらです。

Dim 作成シート As Worksheet
Set 作成シート = Worksheets.Add
Dim 設定シート名 As String
設定シート名 = 名付けるシート名を決める何らかの処理

' エラーをスキップする設定でとりあえず名付けてみる
On Error Resume Next
作成シート.Name = 設定シート名

' スキップされしまった（目的の名前になっていない）なら、(2)をつけてもう一回トライ
If 作成シート.Name <> 設定シート名 Then
    作成シート.Name = 設定シート名 & " (2)"
End If

' エラーをスキップする設定を元に戻す（これを忘れないように！）
On Error GoTo 0

こんな風に、On Error Resume Nextでエラーをスキップし、
「とりあえずシート名つけてみて、失敗してたら(2)をつけてもう一回！」
とやるのが楽です。

もちろんこのマクロでは3つかぶった場合にシート名が変わらないのですが、
商品にして売るマクロでもなければ、この程度で済ませて

「まあ3つ被ったら手で直すか(´∀｀)」

と適度に手作業でカバーして、
コーディングコストを抑えるのも重要なテクニックです。

プログラムって、

だいたい動くコードは30分で作れた。
　⇒　レアケースのエラー対応に3時間かかった。

みたいなことが往々にしてありますからね(笑)

この方法で十分！という方はこちらをお使いください。

「どうしても(3)、(4)…と完璧に処理したい」という方は、
以下のコードと解説にお進みください。

連番付きでシート名を設定する汎用関数を作る

さて「シート名が重複した場合は重複がなくなるまで(3)、(4)…と増やして連番をつける」コードですが、たかがシート名を変えるだけなのに、結構なコード量になります。

これをいちいちメインマクロに書くと、もっと重要な処理が読みづらくなるため、

Dim 作成シート As Worksheet
Set 作成シート = Worksheets.Add
Dim 設定シート名 As String
設定シート名 = 名付けるシート名を決める何らかの処理

Call 重複とエラーを回避したシート名を設定する(作成シート, 設定シート名)

↑このように、「名称を設定したいシート」と「設定するシート名」を渡すと、
シート名が被った場合は連番をつけた上で名付けてくれる関数を作ります。

関数にすると、メインマクロ上では1行で済むようになり、コードが格段に読みやすくなりますし、使いまわしもできるようになりますからね。

今回の目的さえ果たせばいいという方は、
関数だけコピペしたら中身を見ずにCallして使ってもOKです。

それができるというのも、関数化の大事なメリットですからね。

私とチーム開発して、私が担当した関数を使うようなイメージです。

ちゃんと中のコードも理解したいという方は、
せっかくなのでこの機会に関数分割も合わせて勉強してください。

この手の「細部までこだわるコード」を書くレベルに到達したのに、
SubやFunctionを分割しないでやっているといずれ地獄を見ますので…

ではいきますね。

関数のソースコード

Sub 重複とエラーを回避したシート名を設定する(指定シート As Worksheet, ByVal 設定シート名 As String)
    On Error Resume Next

    ' ◇ 既に設定名であればExit
    If 指定シート.Name = 設定シート名 Then: Exit Sub

    ' 禁則文字を削除し31文字内に
    設定シート名 = シート名禁則文字を削除(設定シート名)
    設定シート名 = Left(設定シート名, 31)

    ' ◇ 既存シート名と重複した場合は連番を付与
    If Isシートが存在する(設定シート名, 指定シート.Parent) Then
    
        設定シート名 = Left(設定シート名, 27) ' 連番用の文字数を確保
        Dim i As Long: i = 2
        Do While Isシートが存在する(設定シート名 & " (" & i & ")", 指定シート.Parent)
            i = i + 1
        Loop
        設定シート名 = 設定シート名 & " (" & i & ")"
        
    End If
    
    ' 作成したシート名を設定
    指定シート.Name = 設定シート名

End Sub

Function シート名禁則文字を削除(ByVal 元テキスト As String) As String
    Dim Arr禁則文字リスト
    Arr禁則文字リスト = Split("',’,＇,*,:,?,\,￥,＊,／,：,？,[,［,］,],＼,/,<,>", ",")
    Dim 禁則文字
    For Each 禁則文字 In Arr禁則文字リスト
        元テキスト = Replace(元テキスト, 禁則文字, "")
    Next
    シート名禁則文字を削除 = 元テキスト
End Function

Function Isシートが存在する(判定シート名 As String, 指定ブック As Workbook) As Boolean
    Dim ws As Worksheet
    For Each ws In 指定ブック.Worksheets
        If ws.Name = 判定シート名 Then
            Isシートが存在する = True
            Exit Function
        End If
    Next
End Function

解説

コード自体は基本的なものの組み合わせなので、
1行1行はよく読めば理解できると思います。

せっかく関数にパッケージ化するのであれば、シート名の重複以外に、
「31文字制限」と「禁則文字のチェック」も行ってしまいましょう。

このコードを実現するには、

重複がなくなるまで連番を増やしていくループ
同名シートがあるか調べるためにすべてのシートをループ
すべてのシート名使用禁止文字をループしてReplace

と、3つのループが必要になるのですが、これらをそれぞれ別の関数として作っています。

特に2のループは1のループ中で実行されるため、同じところに書くとループが入れ子になって、無駄にコードが複雑化する恐れがありますからね。

「ループごとに関数化」は、コードをスッキリさせるために重要な手法です。

この機会に、覚えてしまってください。

おまけ：画期的？な方法

今回の処理は、実はループをまったく使わずに実装することもできます。

というか、なんと条件分岐すら使わずに実装できます。

シート名を○○から△△に変える場合の、その方法がこちら↓

Dim シートの元の位置 As Long
シートの元の位置 = Worksheets("○○").Index

Worksheets("○○").Move
ActiveSheet.Name = "△△"

ActiveSheet.Move Before:= Thisworkbook.Sheets(シートの元の位置)