シート上のリストで指定したシート以外を削除する

１　シートを追加する操作を含むマクロを実行した後、追加したシートを削除してシート数を初期化する場合に、デフォルトで存在したシート（削除対象外）のリストを「保存シート」という名前のシートに書いてユーザーが管理できるようにする方法。

　ポイントは、ワークシート関数のCountif。存在判定はCountif。Countifは存在しても存在しなくてもエラーにならない有り難いワークシート関数。

２　コード

Sub リスト内のシート名以外を削除()
    '削除しないシート名が書かれたセル範囲を取得
    'ここでは、「保存シート名」シートに、A1セルに題名、A2セルに「保存シート名」（消さないリストを書き出したシート自分自身の名を書いておかないと消えてしまう）、
    '以下A列の下方向に連続して消したくないシート名を記載してあるものとする。
    With ThisWorkbook.Sheets("保存シート名")
        Dim Rng As Range
        Set Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With
    
    'あとで使うCountIfは半角全角の違いを別文字として不一致判定してしまうので半角に統一してからシート名があるか判定する。
    '(CountIfはもともと大文字小文字の違いは無視して同一と判定するので大文字小文字は別途手当てする必要なし)
    Dim R As Range
    For Each R In Rng
        R.Value = StrConv(R, vbNarrow)
    Next
    
    'すべてのシートについて繰り返す
    Dim Sh As Worksheet
    For Each Sh In ThisWorkbook.Worksheets
        'もしシート名が設定シートのリスト内にない場合、シートを削除する。
        '（注）シート名を半角にしてからリスト（半角に変換済）と比較する。
        If WorksheetFunction.CountIf(Rng, StrConv(Sh.Name, vbNarrow)) = 0 Then
            Application.DisplayAlerts = False
                Sh.Delete
            Application.DisplayAlerts = True
        End If
    Next
End Sub

３　ヤフー知恵袋に既にあった。。。。。

detail.chiebukuro.yahoo.co.jp

このブログもすっきり。

oha-yo.com

Sub test()
'シート一覧にあるシート名を削除する
For Each sh In ActiveWorkbook.Sheets
    sn = sh.Name
    x = WorksheetFunction.CountIf(Worksheets("削除シート一覧").Range("b2:b500"), sn)
    'MsgBox x
    If x > 0 Then
        '削除確認を求めない
        Application.DisplayAlerts = False
        sh.Delete
        Application.DisplayAlerts = True
    End If
    Next
End Sub

youtu.be