excelで不要なStyleが増えてしまうので、削除するマクロを組みました。
そのときのメモ。
参考サイト：https://gist.github.com/YoshihitoAso/311b0a1d40174e1bfdae
参考サイトと違うところ：
１．複数のファイルを対象にStyleの削除を行う
（Excelのシートから対象フォルダを選択→実行させたい）
２．Styleの削除を行ったファイル名と削除した件数を書き出す
３．名前定義の削除を選択したい
完成図
完成図はこんな感じ。
操作としては、
i) 「対象のディレクトリ選択」ボタンでディレクトリを選択
→選択するとB6のセルに、選択したディレクトリパスが表示される
ii) C6セルで、選択した配下にある子ディレクトの下のファイルもすべて対象にするか選択
TRUE：子ディレクトリ含むすべてのファイルを対象とする
FALSE: 選択したディレクトリのファイルのみ対象とする
iii) 名前定義も含めて削除するか選択
TRUE： 名前定義も削除する
FALSE: 名前定義を削除対象にしない
iv) 「実行」ボタン
→完了後、B10/C10/D10セル以降にそれぞれ、
Bセル：対象としたファイルの名前
Cセル：削除したスタイルの数
Dセル：実行した日付
を記入する。（ログとして活用）
実際に作成していく
プロジェクトの構成
実際にマクロを組んでいくのですが、プロジェクトの構成を先に。
上記１で「対象のディレクトリ選択」ボタンを作成しましたが、このボタンを右クリックして、
「マクロを登録」＞ 「新規作成」を押すと、上記の図のように、「標準モジュール」という
モジュールが作成され、コードを記述する画面がでてきます。
が、今回、ボタンの動作はここには書かないことにします。
上記のプロジェクトの構成図で行くと、下記のような感じでわけたいと思います。
（MVC的なことを考えれば、こんな構成が普通かなと思うので、、、なんとなくですがｗ）
※①～⑤の数字は、実装していく予定の順番です
-VBAPProject(remTest.xlsx)
|_MicroSoft Excel Objects
| |_Sheet1(Sheet1)
| |_「対象のディレクトリ選択」ボタンを押したときに呼ばれる関数②
| |_「実行！」ボタンを押したときに呼ばれる関数⑥
| |_Sheet2(Sheet2)
| |_Sheet3(Sheet3)
| |_ThisWorkbook
|
|_標準モジュール
|_Module1
|_ファイル選択ロジック（「ファイル選択」ボタンから呼ばれる①
|_名前定義削除ロジック（「実行！」ボタンの関数から呼ばれる③
|_標準以外のStyleの削除ロジック（「実行！」ボタンの関数から呼ばれる④
|_名前定義削除ロジックと標準以外のStyle削除ロジックを呼び出すメソッド（「実行！」から呼ばれる⑤
（サブディレクトリを対象にする際、再帰的に呼び出す関数として使いたいので、ここにまとめる）
「対象のディレクトリ選択」ボタンの実装
ファイル選択ロジック作成
①のファイル選択ロジック：（Module1に記述)
まずは、ファイルを選択されたときのロジックを作成します。
'フォルダを選択するダイアログを表示して、パスを取得する
'返り値：選択したディレクトリ名(String型)
Function fncSelectFolder() As String
Dim returnString As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
returnString = .SelectedItems(1)
End If
End With
fncSelectFolder = returnString
End Function
コメントに何をしているか書いておりますので、解説は省きますが、2点ほど補足。
・変数宣言は基本、関数の中に書いて、呼ばれたときに初期化させる
（今回は、グローバル変数的に使うことはないので、基本、個々の関数の中で定義します）
・With～End Withは、（VBAを書いている人にはおなじみかもしれませんが）、
With句で呼び出したオブジェクトのプロパティや関数にアクセスする際、オブジェクト名を省略して
記述することができるステートメントです。（上記の場合、If .Showというところで、Application.FileDialogオブジェクトに
アクセスすることができています）なるほど、これはちょっといいね！ｗ
ディレクトリ選択」ボタンを押下時の動きを紐づける
②の「対象のディレクトリ選択」ボタンを押したときの動き、上記２－２－１で作成した関数に紐づけます。
※Sheet1のファイルに記述
'ディレクトリ選択ボタン押下時
Sub btnSelectDirectory_Click()
'エラーは無視
On Error Resume Next
'選択したファイルを保存するための変数
Dim StrPath As String
'ディレクトリの選択
StrPath = Module1.fncSelectFolder()
'Sheet1のB6セルに選択したディレクトリパスを記述
If StrPath <> "" Then
ThisWorkbook.Worksheets("Sheet1").Range("B6").Value = StrPath
End If
End Sub
これで、「対象のディレクトリを選択」ボタンを押すと、ディレクトリ選択のダイアログが表示され、
ディレクトリを選択すると、Sheet1のB6に選択したディレクトリパスが記述されます。
「実行！」ボタンの実装
では、実際にスタイルを削除するロジックを実装します。
名前定義削除ロジック（「実行！」ボタンの関数から呼ばれる③
引数にファイルのフルパスを指定すれば、そのファイルを、指定しなければ現在アクティブなファイルを削除することとします。
（引数なしは、先にOpenなどで対象ファイルを開いていることを前提）
（Module1に記述）
'名前定義を削除する
'引数：削除するファイル名(フルパス）
'返り値：削除した件数（Long型）
Function funcDeleteNamesfunctions(Optional openFileName As String) As Long
'エラーは無視
On Error Resume Next
'引数が存在する場合
If Not (IsMissing(openFileName) Or openFileName ="") Then
'現在のワークブックの名前を覚えておく
Dim baseFileName As String
Dim baseFileSheetName As String
baseFileName = ActiveWorkbook.FullName
baseFileSheetName = ActiveWorkbook.ActiveSheet.Name
'ファイルを開く
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Call Workbooks.Open(openFileName, ReadOnly:=False, Notify:=False)
End If
Dim nm As Name
Dim nmCcnt As Long
For Each nm In ActiveWorkbook.Names
'実際に削除
nm.Delete
nmCnt = nmCnt + 1
Next
'引数が存在する場合
If Not (IsMissing(openFileName) Or openFileName="") Then
'ファイルの保存
ActiveWorkbook.Save
ActiveWorkbook.Close
'元のファイルをアクティブ化させる
Workbooks(baseFileName).Sheets(baseFileSheetName).Active
End If
funcDeleteNamesfunctions = nmCnt
End Function
標準以外のStyleの削除ロジック（「実行！」ボタンの関数から呼ばれる④
こちらも引数にファイルのフルパスを指定すれば、そのファイルを、指定しなければ現在アクティブなファイルを削除することとします。
（引数なしは、先にOpenなどで対象ファイルを開いていることを前提）
'標準以外のスタイルを削除
'引数：削除するファイル名(フルパス:省略可）
'返り値：削除した件数
Function funcDeleteStyle(Optional openFileName As String) As Long
On Error Resume Next
'引数が存在する場合
If Not (IsMissing(openFileName) Or openFileName="") Then
'現在のワークブックの名前を覚えておく
Dim baseFileName As String
Dim baseFileSheetName As String
baseFileName = ActiveWorkbook.FullName
baseFileSheetName = ActiveWorkbook.ActiveSheet.Name
'ファイルを開く
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Call Workbooks.Open(openFileName, ReadOnly:=False, Notify:=False)
End If
Dim i As Long
Dim cnt As Long
Dim style As Object
'対象のファイルに含まれるスタイルの数だけ繰り返す
For i = ActiveWorkbook.Styles.Count To 1 Step -1
'スタイルを取得
Set style = ActiveWorkbook.Styles.Item(i)
'標準以外のスタイルを削除する
If InStr("Hyperlink,Normal,Followed Hyperlink", style.Name) = 0 Then
style.Delete
cnt = cnt + 1
End If
Next
'引数が存在する場合
If Not (IsMissing(openFileName) Or openFileName="") Then
'ファイルの保存
ActiveWorkbook.Save
ActiveWorkbook.Close
'元のファイルをアクティブ化させる
Workbooks(baseFileName).Sheets(baseFileSheetName).Active
End If
'削除した件数を返す
funcDeleteStyle = cnt
End Function
名前定義削除ロジックと標準以外のStyle削除ロジックを呼び出すメソッド（「実行！」から呼ばれる⑤
（サブディレクトリを対象にする際、再帰的に呼び出す関数として使いたいので、ここにまとめる）
（Sheet1に記述）
'実行
'引数：
' 対象のディレクトリパス（String型）
' 名前定義を削除するか（Boolean型）
' サブディレクトリを対象とするか（Boolean型）
'返り値：
' なし
Function funcDeleteSheetStyles(Path As String, NameDelFlg As Boolean, SubDirFlg As Boolean)
On Error Resume Next
Dim buf As String
Dim tgFileName As String
Dim tgDir As Object
Dim n As Long 'ログ書き出し用（書き出す行数）
Dim cnt As Long '標準スタイル削除した数
Dim ncnt As Long '名前定義を削除した数
Dim msg As String '最後に出力する用
'現在のファイルをメモしておく
Dim StrWorkSheetName As String
Dim BaseBookSheet As Worksheet '実行するエクセルのワークブックを覚えておくため
StrWorkSheetName = ActiveWorkbook.ActiveSheet.Name
Set BaseBookSheet = ThisWorkbook.Worksheets(StrWorkSheetName)
'最後の行取得
n = Cells(Rows.Count, "B").End(xlUp).Row + 1
'指定されたディレクトリのファイルを取得する
buf = Dir(Path & "\*.*")
'ディレクトリ内のファイルの数だけ繰り返す
Do While buf <> ""
'拡張子が「.xls」もしくは「.xlsx」のものだけ対象とする
If InStr(buf, ".xls") > 0 Or InStr(buf, ".xlsx") > 0 Then
'処理対象としたファイルを書き出す
BaseBookSheet.Range("B" & n).Value = buf
'対象ファイルを開きActive化する
Application.ScreenUpdating = False
Application.DisplayAlerts = False
tgFileName = Path & "\" & buf
'対象のファイルを開く
Call Workbooks.Open(tgFileName, ReadOnly:=False, Notify:=False)
'名前定義を削除
If NameDelFlg Then
'先に開いてアクティブ化させたので引数なし
ncnt = funcDeleteNamesfunctions()
msg = ncnt & "件の名前定義を削除" & vbNewLine
End If
'標準スタイル以外を削除(これも開いているので引数なし）
cnt = funcDeleteStyle()
'ファイルの保存
Workbooks(buf).Save
Workbooks(buf).Close
'処理した件数の書き出し
BaseBookSheet.Range("C" & n).Value = msg & cnt & "件のスタイル（標準以外）削除"
BaseBookSheet.Range("D" & n).Value = Now
n = n + 1
End If
buf = Dir()
Loop
'サブディレクトリも対象の時
If SubDirFlg Then
With CreateObject("Scripting.FileSystemObject")
For Each tgDirectory In .GetFolder(Path).SubFolders
Call funcDeleteSheetStyles(tgDirectory.Path, NameDelFlg, SubDirFlg) '再帰サブルーチン
Next tgDirectory
End With
End If
End Function
実行！」ボタンを押したときに呼ばれる関数⑤
「実行！」ボタンが押されたときに呼ばれる関数を実装します。
(Sheet1に記述）
'「実行！」ボタン押下時
Sub btnExcec_click()
Dim NameDelFlg As Boolean '名前定義も削除する？
Dim SubDirFlg As Boolean 'サブディレクトリも対象とする？
Dim StrPath As String '対象のディレクトリ名
'現在のファイル
Dim StrWorkSheetName As String
Dim BaseBookSheet As Worksheet '実行するエクセルのワークブックを覚えておくため
StrWorkSheetName = ActiveWorkbook.ActiveSheet.Name
Set BaseBookSheet = ThisWorkbook.Worksheets(StrWorkSheetName)
StrPath = BaseBookSheet.Range("B6").Value
SubDirFlg = BaseBookSheet.Range("C6").Value
NameDelFlg = BaseBookSheet.Range("D6").Value
'パスが入力されていない場合処理終了
If StrPath = "" Then
MsgBox "処理に失敗しました"
End
End If
'実行
Call Module1.funcDeleteSheetStyles(StrPath, NameDelFlg, SubDirFlg)
MsgBox "完了"
End Sub
最後に、ボタンに作成した関数を紐づけて終了
「ディレクトリを選択ボタン」
「ディレクトリを選択」ボタンを右クリック ＞ マクロを登録 ＞ btnSelectDirectory_Click
「実行！」
「実行！」ボタンを右クリック ＞ マクロ登録 ＞ btnExcec_click
上記で完成です。
最後に、上記で作成した2つのコードファイルをペタリしておきます。
[amazonjs asin=”4774173673″ locale=”JP” title=”Excel VBA 本格入門 ~日常業務の自動化からアプリケーション開発まで~”]
[amazonjs asin=”4798047341″ locale=”JP” title=”大村あつし の Excel VBA Win64/32 APIプログラミング”]
[amazonjs asin=”4990512405″ locale=”JP” title=”VBAエキスパート公式テキスト Excel VBA ベーシック 模擬問題プログラム付き”]
[amazonjs asin=”4062577690″ locale=”JP” title=”入門者のExcel VBA―初めての人にベストな学び方 (ブルーバックス)”]
全コード
sheet1(コード）
'ディレクトリ選択ボタン押下時
Sub btnSelectDirectory_Click()
'エラーは無視
On Error Resume Next
'選択したファイルを保存するための変数
Dim StrPath As String
'ディレクトリの選択
StrPath = Module1.fncSelectFolder()
'Sheet1のB6セルに選択したディレクトリパスを記述
If StrPath <> "" Then
ThisWorkbook.Worksheets("Sheet1").Range("B6").Value = StrPath
End If
End Sub
'「実行！」ボタン押下時
Sub btnExcec_click()
Dim NameDelFlg As Boolean '名前定義も削除する？
Dim SubDirFlg As Boolean 'サブディレクトリも対象とする？
Dim StrPath As String '対象のディレクトリ名
'現在のファイル
Dim StrWorkSheetName As String
Dim BaseBookSheet As Worksheet '実行するエクセルのワークブックを覚えておくため
StrWorkSheetName = ActiveWorkbook.ActiveSheet.Name
Set BaseBookSheet = ThisWorkbook.Worksheets(StrWorkSheetName)
StrPath = BaseBookSheet.Range("B6").Value
SubDirFlg = BaseBookSheet.Range("C6").Value
NameDelFlg = BaseBookSheet.Range("D6").Value
'パスが入力されていない場合処理終了
If StrPath = "" Then
MsgBox "処理に失敗しました"
End
End If
'実行
Call Module1.funcDeleteSheetStyles(StrPath, NameDelFlg, SubDirFlg)
MsgBox "完了"
End Sub
Module1（コード）
'フォルダを選択するダイアログを表示して、パスを取得する
'返り値：選択したディレクトリ名(String型)
Function fncSelectFolder() As String
Dim returnString As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
returnString = .SelectedItems(1)
End If
End With
fncSelectFolder = returnString
End Function
'名前定義を削除する
'引数：削除するファイル名(フルパス:省略可）
'返り値：削除した件数（Long型）
Function funcDeleteNamesfunctions(Optional openFileName As String) As Long
'エラーは無視
On Error Resume Next
'引数が存在する場合
If Not (IsMissing(openFileName) Or openFileName="") Then
'現在のワークブックの名前を覚えておく
Dim baseFileName As String
Dim baseFileSheetName As String
baseFileName = ActiveWorkbook.FullName
baseFileSheetName = ActiveWorkbook.ActiveSheet.Name
'ファイルを開く
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Call Workbooks.Open(openFileName, ReadOnly:=False, Notify:=False)
End If
Dim nm As Name
Dim nmCcnt As Long
For Each nm In ActiveWorkbook.Names
'実際に削除
nm.Delete
nmCnt = nmCnt + 1
Next
'引数が存在する場合
If Not (IsMissing(openFileName) Or openFileName="") Then
'ファイルの保存
Workbooks(buf).Save
Workbooks(buf).Close
'元のファイルをアクティブ化させる
Workbooks(baseFileName).Sheets(baseFileSheetName).Active
End If
funcDeleteNamesfunctions = nmCnt
End Function
'標準以外のスタイルを削除
'引数：削除するファイル名(フルパス:省略可）
'返り値：削除した件数
Function funcDeleteStyle(Optional openFileName As String) As Long
On Error Resume Next
'引数が存在する場合
If Not ( IsMissing(openFileName) Or openFileName="") Then
'現在のワークブックの名前を覚えておく
Dim baseFileName As String
Dim baseFileSheetName As String
baseFileName = ActiveWorkbook.FullName
baseFileSheetName = ActiveWorkbook.ActiveSheet.Name
'ファイルを開く
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Call Workbooks.Open(openFileName, ReadOnly:=False, Notify:=False)
End If
Dim i As Long
Dim cnt As Long
Dim style As Object
'対象のファイルに含まれるスタイルの数だけ繰り返す
For i = ActiveWorkbook.Styles.Count To 1 Step -1
'スタイルを取得
Set style = ActiveWorkbook.Styles.Item(i)
'標準以外のスタイルを削除する
If InStr("Hyperlink,Normal,Followed Hyperlink", style.Name) = 0 Then
style.Delete
cnt = cnt + 1
End If
Next
'引数が存在する場合
If Not (IsMissing(openFileName) Or openFileName="") Then
'ファイルの保存
Workbooks(buf).Save
Workbooks(buf).Close
'元のファイルをアクティブ化させる
Workbooks(baseFileName).Sheets(baseFileSheetName).Active
End If
'削除した件数を返す
funcDeleteStyle = cnt
End Function
'実行
'引数：
' 対象のディレクトリパス（String型）
' 名前定義を削除するか（Boolean型）
' サブディレクトリを対象とするか（Boolean型）
'返り値：
' なし
Function funcDeleteSheetStyles(Path As String, NameDelFlg As Boolean, SubDirFlg As Boolean)
On Error Resume Next
Dim buf As String
Dim tgFileName As String
Dim tgDir As Object
Dim n As Long 'ログ書き出し用（書き出す行数）
Dim cnt As Long '標準スタイル削除した数
Dim ncnt As Long '名前定義を削除した数
Dim msg As String '最後に出力する用
'現在のファイルをメモしておく
Dim StrWorkSheetName As String
Dim BaseBookSheet As Worksheet '実行するエクセルのワークブックを覚えておくため
StrWorkSheetName = ActiveWorkbook.ActiveSheet.Name
Set BaseBookSheet = ThisWorkbook.Worksheets(StrWorkSheetName)
'最後の行取得
n = Cells(Rows.Count, "B").End(xlUp).Row + 1
'指定されたディレクトリのファイルを取得する
buf = Dir(Path & "\*.*")
'ディレクトリ内のファイルの数だけ繰り返す
Do While buf <> ""
'拡張子が「.xls」もしくは「.xlsx」のものだけ対象とする
If InStr(buf, ".xls") > 0 Or InStr(buf, ".xlsx") > 0 Then
'処理対象としたファイルを書き出す
BaseBookSheet.Range("B" & n).Value = buf
'対象ファイルを開きActive化する
Application.ScreenUpdating = False
Application.DisplayAlerts = False
tgFileName = Path & "\" & buf
'対象のファイルを開く
Call Workbooks.Open(tgFileName, ReadOnly:=False, Notify:=False)
'名前定義を削除
If NameDelFlg Then
'先に開いてアクティブ化させたので引数なし
ncnt = funcDeleteNamesfunctions()
msg = ncnt & "件の名前定義を削除" & vbNewLine
End If
'標準スタイル以外を削除(これも開いているので引数なし）
cnt = funcDeleteStyle()
'ファイルの保存
Workbooks(buf).Save
Workbooks(buf).Close
'処理した件数の書き出し
BaseBookSheet.Range("C" & n).Value = msg & cnt & "件のスタイル（標準以外）削除"
BaseBookSheet.Range("D" & n).Value = Now
n = n + 1
End If
buf = Dir()
Loop
'サブディレクトリも対象の時
If SubDirFlg Then
With CreateObject("Scripting.FileSystemObject")
For Each tgDirectory In .GetFolder(Path).SubFolders
Call funcDeleteSheetStyles(tgDirectory.Path, NameDelFlg, SubDirFlg) '再帰サブルーチン
Next tgDirectory
End With
End If
End Function