スキップしてメイン コンテンツへ

 none
[Excel VBA] リストから存在しない名前のワークシートを作成する RRS feed

  • 質問

  • ワークブックの最後のワークシートのセル A1 から行 (縦) 方向にそのワークブックの
    ワークシートの名前が一覧になっているとします。

    仮に

    Sheet1
    Sheet2
    Sheet3
    Sheet4
    Sheet5
    ...
    Sheet0 (最後のシート、リストの列記用のシートのためリスト内にはない)

    みたいな感じになっているとします。
    リストの名前はワークシートの順番通りに並んでいるとします。

    この時にそのリストから特定のワークシート名だけ抽出してそれ以外のワークシートを
    削除するようなマクロを組みました。
    (以下のコードではほかに開いているワークブックなどのことは考慮していません)

    Sub test()
        Dim ws As Worksheet
        Dim rng As Range, area As Range
        Dim IsExecte As Boolean
    
        ' ワークシートをループ処理する
        For Each ws In Worksheets
            ' 最後のワークシートは処理しない
            If ws Is Worksheets(Worksheets.Count) Then
                Exit For
            End If
            IsExecte = False
            ' Sheet1, Sheet3, Sheet4, Sheet5 を残して他のワークシートは削除
            For Each area In Worksheets(Worksheets.Count).Range("a1,a3:a5").Areas
                For Each rng In area
                    If ws.Name = rng.Value Then
                        IsExecte = True
                        Exit For
                    End If
                Next
            Next
            If IsExecte = False Then
                Application.DisplayAlerts = False
                ws.Delete
                Application.DisplayAlerts = True
            End If
        Next
        ' 最後のワークシートを削除
        Application.DisplayAlerts = False
        Worksheets(Worksheets.Count).Delete
        Application.DisplayAlerts = True
    End Sub
    

    処理中にリストの中にあるのにその名前のワークシートがなかったときに
    その名前のワークシートをその場所に効率よく挿入する方法はないでしょうか。
    (作る方法さえ分かればいいです)

    例えば上記の例で Sheet4 という名前のワークシートがなかったら
    Sheet3 と Sheet5 の間に Sheet4 を挿入する。
    また、残す対象が Sheet1, Sheet4, Sheet5 のときに Sheet1 がなかったら
    最初に挿入するなど。

    2019年10月28日 5:29

すべての返信

  • 私見ですが、最外枠のループを「For Each ws In Worksheets」にするから面倒なのであって、はじめから「Worksheets(Worksheets.Count).Range("a1.a3:a5").Areas」をループすれば、追加 or 削除 の評価がすっきりしそうです。

    蛇足ですが、現在コードの Exit For が二重For文を抜けていないので無駄な気がします。

    2019年10月28日 7:07
  • 私見ですが、最外枠のループを「For Each ws In Worksheets」にするから面倒なのであって、はじめから「Worksheets(Worksheets.Count).Range("a1.a3:a5").Areas」をループすれば、追加 or 削除 の評価がすっきりしそうです。

    蛇足ですが、現在コードの Exit For が二重For文を抜けていないので無駄な気がします。

    回答ありがとうございます。
    しかし、追加 or 削除ではなく、実際には追加 and 削除 (これもちょっと違う?)
    みたいな感じです。
    すべてのワークシートを対象にリストと一致する名前のワークシートがあったら残し、
    なかったら削除し、リストにあるのにその名前のワークシートがなかったら追加する
    という処理がしたいのです。
    二重ループの内の外側 (?) の Exit For がないのは記入ミスです。
    (実際のコード内ではあったはずだけど、サンプル用に書いてたら消えてしまったようです)

    少し修正。
    (本当は If ws Is Worksheets(Worksheets.Count) Then の部分もちょっと
    直したほうがいいかもしれないと思いましたがとりあえずこのままにします)

    Sub test()
        Dim ws As Worksheet
        Dim rng As Range, area As Range
        Dim IsExecte As Boolean
    
        ' ワークシートをループ処理する
        For Each ws In Worksheets
            ' 最後のワークシートは処理しない
            If ws Is Worksheets(Worksheets.Count) Then
                IsExecte = True
                Exit For
            End If
            IsExecte = False
            ' Sheet1, Sheet3, Sheet4, Sheet5 を残して他のワークシートは削除
            For Each area In Worksheets(Worksheets.Count).Range("a1,a3:a5").Areas
                For Each rng In area
                    If ws.Name = rng.Value Then
                        IsExecte = True
                        Exit For
                    End If
                Next
                If IsExecte Then
                    Exit For
                End If
            Next
            If IsExecte = False Then
                Application.DisplayAlerts = False
                ws.Delete
                Application.DisplayAlerts = True
            End If
        Next
        ' 最後のワークシートを削除
        Application.DisplayAlerts = False
        Worksheets(Worksheets.Count).Delete
        Application.DisplayAlerts = True
    End Sub
    2019年10月28日 7:55
  • > しかし、追加 or 削除ではなく、実際には追加 and 削除 (これもちょっと違う?)
    > みたいな感じです。

    そのつもりで回答しましたが舌足らずだったようで・・^^;

    下のコードでどうでしょう?

    (手打ちしているだけなのでいろいろと不具合があるかも・・)


    For Each area In Worksheets(Worksheets.Count).Range("a1,a3:a5").Areas
        For Each rng In area
            intCount = intCount

            If Worksheets(intCount).Name <> rng.Value Then
                On Error Resume Next
                Set shCheck = Nothing
                Set shCheck = Worksheets(rng.Value)
                On Error Goto 0
                
                If shCheck Is Nothing Then
                    Worksheets.Add(Before:=Worksheets(intCount)).Name = rng.Value
                Else
                    Application.DisplayAlerts = False
                    Worksheets(intCount).Delete
                    Application.DisplayAlerts = True
                End if

            End If
        Next
    Next

    2019年10月28日 8:49
  • お返事、ありがとうございます。
    あれから、いろいろと自分でも試行錯誤したり考えたりした結果、
    For Each ループだけでは難しそうと思い、結局あきらめて
    動的配列にいったん格納して処理することにしました。

    Sub test()
        Dim ws As Worksheet
        Dim rng As Range
        Dim IsExecte As Boolean
        Dim v As Variant
    
        ' 最後のワークシートの名前が Sheet0 でなかったら処理しない
        If Worksheets(Worksheets.Count).Name <> "Sheet0" Then
            Exit Sub
        End If
    
        ' 動的配列を初期化 (UBound(v) = -1)
        v = Array()
    
        ' 残すワークシートの名前を配列に入れる
        For Each rng In Worksheets(Worksheets.Count).Range("a1,a3:a5")
            ReDim Preserve v(UBound(v) + 1)
            v(UBound(v)) = rng.Value
        Next
    
        ' 配列添字の最小値
        cnt = LBound(v)
    
        ' ワークシートをループ処理する
        For Each ws In Worksheets
            ' 最後のワークシートは処理しない
            If ws Is Worksheets(Worksheets.Count) Then
                IsExecte = True
                Exit For
            End If
            IsExecte = False
    
            ' 対象のワークシートかどうかを調べる
            For i = cnt To UBound(v)
                If ws.Name = v(i) Then
                    ' 対象のワークシートが見つかり、リストの中に存在していない
                    ' ワークシートがそれより前にある場合
                    If i <> cnt Then
                        ' ワークシートを作成する
                        For j = cnt To i - 1
                            Worksheets.Add(ws).Name = v(j)
                        Next
                    End If
                    ' ループの初期カウント値を指定する
                    cnt = i + 1
                    IsExecte = True
                    ' ループを抜ける
                    Exit For
                ElseIf i = UBound(v) Then
                    ' リストを最後まで調べてもワークシートが該当しない場合は削除
                    Application.DisplayAlerts = False
                    ws.Delete
                    Application.DisplayAlerts = True
                    Set ws = Nothing
                    Exit For
                End If
            Next
    
            ' 残ったワークシートの名前をイミディエイトウィンドウに出力
            If Not ws Is Nothing Then
                Debug.Print ws.Name
            End If
        Next
    
        ' 最後のワークシートを削除
        Application.DisplayAlerts = False
        Worksheets(Worksheets.Count).Delete
        Application.DisplayAlerts = True
    End Sub
    
    

    おそらく、これで大丈夫だと思いますが・・・。
    せっかく回答いただいたのに無駄になってしまい、申し訳ありません。

    2019年10月29日 2:35