エクセルVBA100本ノック。１４本目：社外秘シート削除

エクセルVBA100本ノック

この記事から得るもの

シート名に社外秘を含むSheetを削除する方法が分かる。
社外秘以外のSheetのセルに、社外秘含む数式を削除する方法が分かる。
全てのセルを値貼り付けする方法が分かる。

１　今回のお題

客先へ送付するブックを作成します。
シート名に「社外秘」の文字が含まれるシートを削除してください。
他のシートは計算式を消して値だけにしてください。
※シート間参照の数式あり。
※条件付き書式・入力規則は未使用。
※対象はアクティブブックで構いません。

excel-ubara.com

２　今回のお題の意図

秘密情報保護に関する問題となっております。
社外秘を含むデータはすべて無くした状態にしたBookを作成し、社外に公開できるものを作るという意図があると思われます。

３　回答

私の最初の回答

Sub ノック14本目_1()


Dim TragetSheetName As String
Dim SearchedRng As Range


'社外秘を含まないSheetの数式に社外秘を含んでいれば、値貼り付けする。
For Each ws In ThisWorkbook.Sheets

    TragetSheetName = ws.Name
    
    If Not TragetSheetName Like "*社外秘*" Then
        Do
            '数式を部分一致で検索
            Set SearchedRng = ws.Cells.Find(what:="社外秘", LookIn:=xlFormulas, lookat:=xlPart)
            If SearchedRng Is Nothing Then: Exit Do
            
            '数式を値貼り付けにする
            SearchedRng.Copy
            SearchedRng.PasteSpecial xlPasteValues
        Loop
    End If
Next


'社外秘の文字を含むSheetの削除
For Each ws In ThisWorkbook.Sheets
    TragetSheetName = ws.Name
    
    If TragetSheetName Like "*社外秘*" Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
    End If
Next

End Sub

まずは社外秘のSheetを削除…ではなく、社外秘Sheetのデータを参照しているSheet名に社外秘を含まないSheetを作成する必要があります。
なので、数式の中に社外秘を含むものを値貼り付けします。その後、社外秘を含むSheetを削除します。

しかし、問題発生。
１　他のBookを参照している可能性がある。
２　すべてのSheetが社外秘であれば、エラーになる。

問題点２つに対応したのが以下のコード

Sub ノック14本目_2()

Dim TragetSheetName As String
Dim SearchedRng As Range


'全Sheetが社外秘か確認する処理
Dim DelFlg As Integer: DelFlg = 0

For Each ws In ThisWorkbook.Sheets
    
    TragetSheetName = ws.Name
    
    If TragetSheetName Like "*社外秘*" Then: DelFlg = DelFlg + 1
Next

If ThisWorkbook.Sheets.Count = DelFlg Then
    MsgBox "全てのSheetが削除対象です。送付すべきSheetを確認してください。": Exit Sub
End If


'社外秘を含まないSheetの数式に社外秘を含んでいれば、値貼り付けする。
For Each ws In ThisWorkbook.Sheets

    TragetSheetName = ws.Name
    
    If Not TragetSheetName Like "*社外秘*" Then
        ws.UsedRange.Value = ws.UsedRange.Value
    End If
Next


'社外秘の文字を含むSheetの削除
For Each ws In ThisWorkbook.Sheets
    TragetSheetName = ws.Name
    
    If TragetSheetName Like "*社外秘*" Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
    End If
Next

End Sub


まず、削除対象ファイルをCountする。すべてのSheet数が削除対象ならエラーとする。
次に、社外秘を含まないSheetの数式に社外秘を含んでいれば、値貼り付けする。これは、 ws.UsedRange.Value = ws.UsedRange.Valueで対応。

４　

今回は、個人情報の一つ上の秘密のデータを扱う処理。こういうデータを、マクロでどうにかしようというのも考え物だが実際に会社で使われている人もいたので需要はあるのだろう。
秘密を扱うPC、USBくらいは限定したいところである。
しかし、VBAでできる限りの配慮をしてあげることも必要なのだろう。

また、今回はFor each inの処理を繰り返し書くことが多かったので、こういう部分はサブルーチン化していくべきなのだろう。

ではでは、このへんで(^^)/~~~