Excelのユーザースタイルの使用状況を調べるマクロ

Excel のユーザースタイルの使用状況を調べるマクロを作りました。ユーザースタイルを適用している、ワークシートやセルアドレスを知ることができます。以前に作った「スタイル設定をシートに出力する　VBAマクロ」の兄弟ツールになります。

結果は新しいシートに表示されます。この一覧ではユーザースタイルが適用されているシート名、セルアドレス、セルの内容、ユーザースタイル名、ユーザースタイルの設定内容などを表示します。

Excel のワークシート内で使用しているユーザースタイルを調査します。

使い方

1. 調査対象のワークブックを開く。
2. VBAプロジェクトの標準モジュールにModule_Debug_Styles.basを登録。
3. user_style_inspectorを実行。

発見したユーザースタイルは新しいシートに表示されます。

コードはいくつかのプロシージャに分かれていますがuser_style_inspectorが本体です。

文字コードに注意！

Gistにアップロードしているファイルエンコードは便宜上UTF-8になっています。しかしながら、VBAプロジェクトの保存ファイルのファイルエンコードはShift_JISが使用されています。そのため、VBAプロジェクトにModule_Debug_Styles.basをインポートする場合は、事前に文字コードを変換する必要があります。（文字化けします）

文字コードの変換にはテキストエディタや変換ツールなどを使用しますが、面倒な場合はブラウザ上のコードをコピペするなどして工夫してください。

view raw how_to_use.md hosted with ❤ by GitHub

	Attribute VB_Name = "Module_Debug_Styles"
	Option Private Module
	Option Explicit
	'このモジュールは、デバッグ用。
	'-------------------------------------------------------------------------------
	'
	'ユーザースタイルの構造体
	'
	'20160607 作成
	'
	Public Type CellStyle
	SheetName As String ' 0: シート名
	A1 As String ' 1: 位置 (セルアドレス A1形式)
	CellText As String ' 2: セルの値
	BuiltIn As String ' 3: スタイルの種類 "組み込み" or "ユーザー"
	StyleName As String ' 4: スタイル名
	IncludeNumber As String ' 5: 表示形式
	VerticalAlignment As String ' 6: 配置縦 xlVAlign
	HorizontalAlignment As String ' 7: 配置横 XlHAlign
	FontName As String ' 8: フォント名
	FontSize As String ' 9: フォントサイズ
	BorderLeft As String '10: 罫線左
	BorderRight As String '11: 罫線右
	BorderTop As String '12: 罫線上
	BorderBottom As String '13: 罫線下
	BorderDiagonalDown As String '14: 罫線右斜め下
	BorderDiagonalUp As String '15: 罫線右斜め上
	Patterns As String '16: パターン XlPattern
	Locked As String '17: 保護 ロック
	FormulaHidden As String '18: 保護 非表示
	End Type
	'
	'セルアドレスの数値部分を指定した桁数でフォーマットする
	'
	'引数: A1形式の文字列、行番号にあたる数値部分の桁数。
	'戻り値: 数値部分をフォーマットしたセルアドレスの文字列
	'
	'使用例: セルアドレス"B3"を3桁でフォーマットする場合
	' conv_a01("B3",3) # => "B003"
	'
	'20160606 作成。セルアドレス順にソートするために作成。
	'
	Function conv_a01(mystr As String, num_length As Long) As String
	On Error Resume Next
	Dim reg As Object
	Dim match As Object
	Dim matches As Object
	Dim num_str As String
	'正規表現オブジェクトを作成
	Set reg = CreateObject("VBScript.RegExp")
	With reg
	.Pattern = "([A-Za-z]+)([0]*)([0-9]+)"
	.IgnoreCase = False
	.Global = True
	End With
	If Len(mystr) <= 0 Then
	conv_a01 = ""
	Exit Function
	End If
	'A1形式の文字列を検索
	Set matches = reg.Execute(mystr)
	'マッチしたコレクションを置換
	For Each match In matches
	num_str = Format(match.submatches(2), String(num_length, "0"))
	mystr = reg.Replace(mystr, "$1" & num_str)
	Next match
	conv_a01 = mystr
	End Function
	'
	'指定したセル範囲のスタイルを調査する。
	'
	'引数: 調査するセル範囲 range型
	'戻り値: CellStyle構造体の配列
	'
	'20160607 作成。スタイル調査部分を独立させた。
	'
	Function get_cell_style(myrange As Range) As CellStyle()
	On Error Resume Next
	Dim style_tmp As String
	Dim style_val As Long
	Dim border_pos As Integer
	Dim border(5) As String
	Dim r As Range
	Dim i As Long
	Dim border_xl As Variant
	border_xl = Array(xlLeft, xlRight, xlTop, xlBottom, xlDiagonalDown, xlDiagonalUp)
	Dim border_name As Variant
	border_name = Array("左", "右", "上", "下", "右斜め下", "右斜め上")
	'スタイル格納用の配列
	Dim cs() As CellStyle
	ReDim cs(myrange.Count)
	i = 0
	For Each r In myrange
	' 0: シート名
	cs(i).SheetName = r.Parent.Name
	' 1: 位置 (セルアドレス)
	cs(i).A1 = r.Address(0, 0)
	' 2: セルの値
	cs(i).CellText = r.Text
	' 3: 種類 "ユーザー"
	If r.Style.BuiltIn Then
	'組込みスタイル
	style_tmp = "組込"
	Else
	'ユーザースタイル
	style_tmp = "ユーザー"
	End If
	cs(i).BuiltIn = style_tmp
	' 4: スタイル名
	cs(i).StyleName = r.Style.NameLocal
	' 5: 表示形式
	If r.Style.IncludeNumber Then
	style_tmp = r.NumberFormatLocal
	Else
	style_tmp = "-"
	End If
	cs(i).IncludeNumber = style_tmp
	'配置
	If r.Style.IncludeAlignment Then
	' 6: 配置縦 xlVAlign
	style_val = r.Style.VerticalAlignment
	Select Case style_val
	Case xlVAlignTop
	style_tmp = "上"
	Case xlVAlignCenter
	style_tmp = "中央"
	Case xlVAlignBottom
	style_tmp = "下"
	Case xlVAlignJustify
	style_tmp = "両端揃え"
	Case xlVAlignDistributed
	style_tmp = "均等割り付け"
	Case Else
	style_tmp = ""
	End Select
	cs(i).VerticalAlignment = style_tmp
	' 7: 配置横 XlHAlign
	style_val = r.Style.HorizontalAlignment
	Select Case style_val
	Case xlHAlignGeneral
	style_tmp = "標準"
	Case xlHAlignLeft
	style_tmp = "左"
	Case xlHAlignCenter
	style_tmp = "中央"
	Case xlHAlignRight
	style_tmp = "右"
	Case xlHAlignFill
	style_tmp = "繰り返し"
	Case xlHAlignJustify
	style_tmp = "両端揃え"
	Case xlHAlignCenterAcrossSelection
	style_tmp = "選択範囲で中央"
	Case xlHAlignDistributed
	style_tmp = "均等割り付け"
	Case Else
	style_tmp = ""
	End Select
	cs(i).HorizontalAlignment = style_tmp
	Else
	cs(i).VerticalAlignment = "-"
	cs(i).HorizontalAlignment = "-"
	End If
	'フォント
	If r.Style.IncludeFont Then
	' 8: フォント名
	cs(i).FontName = r.Style.Font.Name
	' 9: フォントサイズ
	cs(i).FontSize = r.Style.Font.Size
	Else
	cs(i).FontName = "-"
	cs(i).FontSize = "-"
	End If
	'罫線　XlLineStyle
	If r.Style.IncludeBorder Then
	For border_pos = 0 To 5
	style_val = r.Style.Borders(border_xl(border_pos)).LineStyle
	If style_val <> xlLineStyleNone Then
	border(border_pos) = border_name(border_pos)
	Else
	border(border_pos) = "なし"
	End If
	Next border_pos
	cs(i).BorderLeft = border(0) '10: 罫線左
	cs(i).BorderRight = border(1) '11: 罫線右
	cs(i).BorderTop = border(2) '12: 罫線上
	cs(i).BorderBottom = border(3) '13: 罫線下
	cs(i).BorderDiagonalDown = border(4) '14: 罫線右斜め下
	cs(i).BorderDiagonalUp = border(5) '15: 罫線右斜め上
	Else
	cs(i).BorderLeft = "-"
	cs(i).BorderRight = "-"
	cs(i).BorderTop = "-"
	cs(i).BorderBottom = "-"
	cs(i).BorderDiagonalDown = "-"
	cs(i).BorderDiagonalUp = "-"
	End If
	'16: パターン XlPattern
	If r.Style.IncludePatterns Then
	If r.Style.Interior.Pattern = xlPatternNone Then
	style_tmp = "網かけなし"
	Else
	style_tmp = "網かけ"
	End If
	Else
	style_tmp = "-"
	End If
	cs(i).Patterns = style_tmp
	'保護
	If r.Style.IncludeProtection Then
	'17: 保護 ロック
	If r.Style.Locked Then
	style_tmp = "ロック"
	Else
	style_tmp = ""
	End If
	cs(i).Locked = style_tmp
	'18: 保護 非表示
	If r.Style.FormulaHidden Then
	style_tmp = "表示しない"
	Else
	style_tmp = "表示"
	End If
	cs(i).FormulaHidden = style_tmp
	Else
	cs(i).Locked = "-"
	cs(i).FormulaHidden = "-"
	End If
	i = i + 1
	Next r
	get_cell_style = cs()
	End Function
	'
	'ワークブック内で使用しているユーザースタイルを調査。その結果を新しいシートに表示する｡
	'一覧をシート名順、セルアドレス順にソート。
	'
	'20160608 作成。セルスタイルの調査をget_cell_style()で行うようにした。
	'
	Sub user_style_inspector()
	On Error GoTo ERROR_STYLE
	With Application
	'画面更新停止
	.ScreenUpdating = False
	'自動再計算を停止
	.Calculation = xlManual
	End With
	Dim sheet As Worksheet
	Dim row_max As Long
	Dim col_max As Long
	Dim r1 As Long
	Dim c1 As Long
	Dim r1c1_str As String
	Dim a1_str As String
	Dim mycell As Range
	Dim max_length As Long
	Dim bltin_count As Long
	Dim not_bltin_count As Long
	Dim n As Long
	Dim i As Long
	Dim cs() As CellStyle
	Dim tmp() As Variant
	Dim list_title As Variant
	list_title = Array("シート名", "位置", "セルの値", "種類", "スタイル名", _
	"表示形式", "配置 縦", "配置 横", "フォント名", "サイズ", _
	"罫線", "罫線", "罫線", "罫線", "罫線", _
	"罫線", "パターン", "保護", "数式表示")
	n = 0
	max_length = 0
	ReDim Preserve tmp(18, n)
	For Each sheet In ActiveWorkbook.Sheets
	With sheet.Range("A1").SpecialCells(xlLastCell)
	row_max = .row
	col_max = .Column
	End With
	Debug.Print "sheet name = " & sheet.Name
	r1 = 1
	While r1 <= row_max
	c1 = 1
	While c1 <= col_max
	Set mycell = sheet.Cells(r1, c1)
	If mycell.Style.BuiltIn Then
	'組込みスタイル
	bltin_count = bltin_count + 1
	Else
	'ユーザースタイル
	not_bltin_count = not_bltin_count + 1
	'セルアドレス変換
	r1c1_str = "R" & r1 & "C" & c1
	a1_str = Application.ConvertFormula(r1c1_str, xlR1C1, xlA1, xlRelative)
	'ユーザースタイルが適用されているセルの、行の値の最大値の桁数を取得
	If Len(CStr(r1)) > max_length Then
	max_length = Len(CStr(r1))
	End If
	'セルのスタイルを取得
	ReDim Preserve tmp(18, n)
	i = mycell.Count - 1
	ReDim cs(i)
	cs = get_cell_style(mycell)
	tmp(0, n) = cs(i).SheetName ' 0: シート名
	tmp(1, n) = cs(i).A1 ' 1: 位置 (セルアドレス)
	tmp(2, n) = cs(i).CellText ' 2: セルの値
	tmp(3, n) = cs(i).BuiltIn ' 3: 種類 "ユーザー"
	tmp(4, n) = cs(i).StyleName ' 4: スタイル名
	tmp(5, n) = cs(i).IncludeNumber ' 5: 表示形式
	tmp(6, n) = cs(i).VerticalAlignment ' 6: 配置縦 xlVAlign
	tmp(7, n) = cs(i).HorizontalAlignment ' 7: 配置横 XlHAlign
	tmp(8, n) = cs(i).FontName ' 8: フォント名
	tmp(9, n) = cs(i).FontSize ' 9: フォントサイズ
	tmp(10, n) = cs(i).BorderLeft '10: 罫線左
	tmp(11, n) = cs(i).BorderRight '11: 罫線右
	tmp(12, n) = cs(i).BorderTop '12: 罫線上
	tmp(13, n) = cs(i).BorderBottom '13: 罫線下
	tmp(14, n) = cs(i).BorderDiagonalDown '14: 罫線右斜め下
	tmp(15, n) = cs(i).BorderDiagonalUp '15: 罫線右斜め上
	tmp(16, n) = cs(i).Patterns '16: パターン XlPattern
	tmp(17, n) = cs(i).Locked '17: 保護 ロック
	tmp(18, n) = cs(i).FormulaHidden '18: 保護 非表示
	n = n + 1
	End If
	c1 = c1 + 1
	Wend
	r1 = r1 + 1
	Wend
	Debug.Print "組み込みスタイル = " & bltin_count & ", ユーザースタイル = " & not_bltin_count
	bltin_count = 0
	not_bltin_count = 0
	Next sheet
	'ユーザースタイルが無ければ終了
	If tmp(0, 0) = "" Then
	With Application
	'自動再計算を自動に
	.Calculation = xlAutomatic
	'画面更新開始
	.ScreenUpdating = True
	End With
	Exit Sub
	End If
	'ユーザースタイル使用セルの一覧を出力
	Dim sh As Worksheet
	Set sh = ActiveWorkbook.Worksheets.Add
	Dim table_rc As Range
	Dim table_i As Long
	Dim table_row As Long
	Dim table_col As Long
	table_row = UBound(tmp, 2) + 1
	table_col = UBound(tmp, 1) + 1
	'タイトル表示
	sh.Range("a1").Resize(1, UBound(list_title) + 1).Value = list_title
	'調査結果の配列tmpをセルへ書き込む
	sh.Range("A2").Resize(table_row, table_col) = WorksheetFunction.Transpose(tmp)
	'セルアドレスをフォーマット
	Dim r As Range
	For Each r In sh.Range("B2").Resize(table_row)
	r.Value = conv_a01(r.Value, max_length)
	Next r
	'sort:　シート名：昇順、　位置：昇順、　先頭行：タイトル
	With sh.Range("A1").Resize(table_row + 1, table_col)
	.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1"), Order2:=xlAscending, Header:=xlYes, MatchCase:=False
	.Font.Size = 9
	.Columns.AutoFit
	End With
	'セルの値の列幅
	sh.Columns(3).ColumnWidth = 20
	'セルの値を表示
	For table_i = 2 To table_row + 1
	Set table_rc = sh.Range("A" & table_i)
	Worksheets(table_rc.Text).Range(table_rc.Offset(0, 1).Text).Copy Destination:=table_rc.Offset(0, 2)
	Next table_i
	Erase tmp
	With Application
	'自動再計算を自動に
	.Calculation = xlAutomatic
	'画面更新開始
	.ScreenUpdating = True
	End With
	Exit Sub
	ERROR_STYLE:
	'エラー時の画面更新の復帰処理
	With Application
	'自動再計算を自動に
	.Calculation = xlAutomatic
	'画面更新開始
	.ScreenUpdating = True
	End With
	r1c1_str = "R" & r1 & "C" & c1
	Debug.Print "error cell = " & Application.ConvertFormula(r1c1_str, xlR1C1, xlA1, xlRelative)
	End Sub
	'-------------------------------------------------------------------------------
	'
	'get_cell_style()のテスト
	'
	'引数に、セル範囲を指定する場合
	'
	Sub test_get_cell_style()
	Dim r_count As Long
	Dim cs() As CellStyle
	Dim i As Long
	Dim mycell As Range
	Set mycell = Range("A1:C3")
	r_count = mycell.Count - 1
	ReDim cs(r_count)
	cs = get_cell_style(mycell)
	For i = 0 To r_count
	Debug.Print "位置 (セルアドレス) = " & cs(i).A1
	Debug.Print "セルの値 = " & cs(i).CellText
	Debug.Print "種類 = " & cs(i).BuiltIn
	Debug.Print "スタイル名 = " & cs(i).StyleName
	Next i
	End Sub

view raw Module_Debug_Styles.bas hosted with ❤ by GitHub