はじめに

今回は、Excelの検索関連のマクロ作成です。
Excelの検索には書式検索があり、文字色や取り消し線など、色々な書式で検索することができます。
しかし、この場合少し制限があり、セル自体がひとつの書式になっている必要性があると思います（たぶん）。
そうなってくると意外と不便で、セル内の一部の文字色だけ違ったり、取り消し線があったりする場合、検索できません。
今回はそれを検索できるようにするマクロをつくります。

色々やっていたら複雑になってしまいました。

今回実施する内容

以下のような検索機能を作成する。Excelの検索フォームに似た感じで作成します。
・指定の文字色で検索
・取り消し線で検索
・取り消し線を削除

本機能は、リボン上にマクロを実装しアドイン化します（第2回参照）。

・リボン

・文字色、もしくは、取り消し線で検索

・文字色選択画面

・取り消し線を削除

ソースコード(Git Hub)

VBA_07_Find

今回作成、編集したソースコードは以下です。
もともとのorgMacroに追加したため、元のソースについては割愛します。
●作成分
・FindForm.frm
・Find.bas
・WorkbookValidation.bas
・Cls_ColorPalette.cls

●修正分
・Constant.bas
・CreateObject.bas
・Ribbon.bas

環境

OS:Windows 10 JP
Excel: Excel 2019 (64bit)

参考

Excel VBA 第1回例外処理の対応（どのモジュールの、どの関数で例外は発生したのか？）
エラー検出クラスの作成です。今回のマクロでもこのエラー検出マクロを使用します。

Excel VBA 第2回リボンとアドイン作成
オリジナルのリボンを作成し、それをアドインとして読み込むための説明です。
今回は、これを使って検索機能をアドインにします。

Excel VBA 第4回 ActiveA1作成（すべてのシートのカーサーをA1セルに）
リボンのアドインにActiveA1を追加したものです。
今回はここに検索機能を追加します。

Excel VBA 第5回 Win32APIの取り込みと64bit対応とフォームのサイズ変更
フォームのサイズ変更を可能とする説明です。
今回の検索フォームでも使用します。

Excel VBA 第6回 ProgressBarの作成
プログレスバーで進捗を表示します。
今回の検索は時間がかかるため、使用します。

用語

なし

文字色、取り消し線で検索の動作イメージ

検索については、文字色と取り消し線で同じで、基本的にExcel標準の検索と同じような実装です。

メニューのOrgMacroのリボンの「Find」を押すと、検索フォームが開かれる。
文字色の場合は、文字色ボタンを押すと、色選択が画面が開かれて選択する。
取り消し線の場合は、取り消し線ボタンを押す。
検索結果が表示される。

なお、セル内の文字の文字色や取り消し線を検索する処理は時間がかかるため、ProgressBarで進捗を表示します。
それでも大きなファイルは検索を開始すると終わりませんので、注意が必要です。途中中断は可能です。

置換については機能作成しておらず、取り消し線の削除として作成しました。
文字色については、検索のみです。
自分の使用用途として、これで十分だったためです。

考慮するExcel機能

ここには、Excel機能のなかで考慮したことを記載します。

以下は読み飛ばし可能ですが、
Excelには、知らないものも含め、たくさんの機能があります。それらの機能がマクロを作成していると、エラーの要因になることがたくさんあります。
例えば、第4回で作成したActiveA1はA1セルにカーサーを移動するだけの機能なのですが、シートの保護をして、かつセルの選択もさせないようにすると、簡単にエラーが発生します。
自分やその周辺の人たちで使うだけであればある程度使用する機能が限られるというか、新しいものがあったとしても、マクロを少し更新すればだいたいは対応可能です。しかし、Qiitaのような誰でもみれるようなところで公開すると、様々な環境があってエラーが簡単におきてしまいます。
そこで、本マクロを作成するうえで気にした機能だけは列挙しようと思いました。誰かが新しい機能が原因で動作しないなど言われた場合は、対応を考えるきっかけくらいにはなるかなという程度の意識です。

シート非表示
　　検索自体は非表示シートも実施しますが、非表示シートの選択は難しいため、実施していません。
行列の非表示
　　行列の非表示は、選択に影響しないため、特に考慮していません。
グラフシートのようなワークシート以外のシート
　　グラフシートなどのワークシート以外については検索を実施しません。テキストボックスのようなObjectも検索しません。
　　グラフシートしかないような場合は実施不可能です。
　　その他のシートも考慮対象外です。（使ったことがありませんのでどうなるか不明です。
シートの保護
　　シートの保護状態では、検索は可能ですが、取り消し線の削除はできません。

検索フォームの作成

検索フォームは、できる限りExcelの検索フォームに似せて作る方針としました。

一番上にComboBoxを配置して「Sheet」と「Book」で検索を切り替えられるようにしました。
この部分は、Excelだと、タブの中に含まれていますが、外に出しました。

MultiPageは、FindとStrikethroughを作成し、文字色と取り消し線の検索と、取り消し線の削除でタブを二つにしました。
Excelでは、タブが真っ白なのですが、VBAのFormでは灰色だったため、タブの上に白色のLabelを載せています。

ListViewには検索結果を載せるための領域を確保しました。
Excelの検索とほぼ同等で、シート、セルのアドレス、および、値を表示します。

また、検索ボックスはサイズ変更できるように実装しました。

フォームのソースコードは、以下です。

FindForm.frm

Option Explicit

'-----Windows API定数宣言-----
Private Const GWL_STYLE As Integer = -16  'ウィンドウスタイルのハンドラ番号
Private Const WS_MAXIMIZEBOX As Long = &H10000  'ウィンドウスタイルで最大化ボタンをつける
Private Const WS_MINIMIZEBOX As Long = &H20000  'ウィンドウスタイルで最小化ボタンを付ける
Private Const WS_THICKFRAME As Long = &H40000   'ウィンドウスタイルでサイズ変更をつける
Private Const WS_SYSMENU As Long = &H80000      'ウィンドウスタイルでコントロールメニューボックスをもつウィンドウを作成する

'-----Windows API宣言-----
Option Explicit

'-----Windows API定数宣言-----
Private Const GWL_STYLE As Integer = -16  'ウィンドウスタイルのハンドラ番号
Private Const WS_MAXIMIZEBOX As Long = &H10000  'ウィンドウスタイルで最大化ボタンをつける
Private Const WS_MINIMIZEBOX As Long = &H20000  'ウィンドウスタイルで最小化ボタンを付ける
Private Const WS_THICKFRAME As Long = &H40000   'ウィンドウスタイルでサイズ変更をつける
Private Const WS_SYSMENU As Long = &H80000      'ウィンドウスタイルでコントロールメニューボックスをもつウィンドウを作成する

'-----Windows API宣言-----
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr

# If Win64 Then
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
# Else
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
# End If

'------Const------
Private Const FONT_COLOR_TYPE As Long = 1
Private Const STRIKETHROUGH_TYPE As Long = 2
Private Const ERR_MSG_01 As String = "対象のセルのシートは非表示に設定されています。"

'------Global variable-----
Private G_resultType As Long            'xyzのbit演算。xは未使用。yは取り消し線の結果、zは文字色の結果。
Private G_cellArray() As Range
Private G_numOfResult As Long

'------Property------

'------Function------
'フォームのサイズを変更する。
Public Sub FormResize()
    Dim hwnd As LongPtr
    Dim WndStyle As LongPtr
    
    hwnd = GetActiveWindow()    'ウィンドウハンドルの取得
    WndStyle = GetWindowLongPtr(hwnd, GWL_STYLE)   'ウィンドウのスタイルを取得

    WndStyle = WndStyle Or WS_THICKFRAME    ' Or WS_MAXIMIZEBOX Or WS_SYSMENU
    
    Call SetWindowLongPtr(hwnd, GWL_STYLE, WndStyle)
End Sub

'FindFormが活性化されたときに実施する。
'FIndFormのサイズを変更する。
Private Sub UserForm_Activate()
    Call FormResize
End Sub

'FindFormのサイズが変更されたときに実施する。
'ListView1のサイズをFindFormサイズ変更に伴いサイズを変更する。
Private Sub UserForm_Resize()
    Dim iHeight As Integer
    Dim iWidth As Integer
    
    If Me.InsideWidth > 4 Then ListView1.Width = Me.InsideWidth - ListView1.Left * 2
    If Me.InsideHeight > 76 Then ListView1.Height = Me.InsideHeight - 40
    
End Sub

'FindFormが初期化されたときに実施する。
'ComboBox1、ListVIew1の初期値を設定する。
Private Sub UserForm_Initialize()
    Call ComboBox1.AddItem("Sheet")
    Call ComboBox1.AddItem("Book")
    ComboBox1.ListIndex = 0
    ComboBox1.Style = fmStyleDropDownList
    MultiPage1.Value = 0
    
    ListView1.View = lvwReport
    ListView1.FullRowSelect = True
    Call ListView1.ColumnHeaders.Add(Key:="_Sheet", Text:="Sheet")
    Call ListView1.ColumnHeaders.Add(Key:="_Cell", Text:="Cell")
    Call ListView1.ColumnHeaders.Add(Key:="_Text", Text:="Text", Width:=300)
End Sub

'Findタブの文字色ボタンを押したとき、文字色で検索を実施する。
Private Sub FontColorBtn_Click()
    Application.ScreenUpdating = False              'DoEventsを実施すると書き換え発生のため、あまり意味がない。
    
    If FindFontColorWCheck(ComboBox1.ListIndex, G_cellArray, G_numOfResult) Then           '正常にFontClor検索処理が終わる場合
        If G_numOfResult > 0 Then               '見つかったセルが1つ以上の場合
            G_resultType = FONT_COLOR_TYPE
            Call ShowResult(G_cellArray)              '結果を出力
        Else
            ListView1.ListItems.Clear
            G_resultType = 0
        End If
    End If
    
    Application.ScreenUpdating = True
End Sub

'Findタブの取り消し線ボタンを押したときに、取り消し線で検索を実施する。
Private Sub StrikethroughBtn_Click()
    Call ExeFindStrikethrough(True)
End Sub

'Strikethroughタブの全削除ボタンを押したとき、取り消し線を検索し、すべて削除する。
Private Sub STDeleteAllButton_Click()
    Dim CellArray() As Range                        '取り消し線の削除結果のセル。この結果はListView1に反映しないため、本関数内のみで扱う。
    Dim lngNumOfResult As Long                      '取り消し線の削除結果の数。この結果はListView1に反映しないため、本関数内のみで扱う。
    
    Application.ScreenUpdating = False              'DoEventsを実施すると書き換え発生のため、あまり意味がない。
        
    If G_resultType = STRIKETHROUGH_TYPE Then       '検索結果がある場合、それをもとにそのセルの当該文字を削除する。（処理に時間がかかるため、検索結果を使用する。Excelの置換は結果の有無にかかわらず再検索しているため違う実装）
        If DeleteStrikethroughWCheck(ComboBox1.ListIndex, G_cellArray, G_numOfResult) Then
            If G_numOfResult > 0 Then
                Call ShowResult(G_cellArray)
            End If
        End If
    Else                                            '取り消し線の検索結果がない場合、検索したうえで、削除する。
        If FindDeleteStrikethroughWCheck(ComboBox1.ListIndex, CellArray, lngNumOfResult) Then     '検索結果がない場合、Excelの置換と同様にG_cellArrayの出力はしない実装とする。
            If lngNumOfResult > 0 And G_resultType = FONT_COLOR_TYPE Then    '取り消し線の削除があり、フォントの検索結果がある場合、ListView1に結果を反映する。
                Call ShowResult(G_cellArray)
            End If
        End If
    End If
    
    Application.ScreenUpdating = True
End Sub

'Strikethroughタブの削除ボタンを押したとき、カーサーのあるセルに取り消し線があるか確認し、
'取り消し線がある場合削除したうえで、次のセルを検索して存在する場合、そのセルへカーサーを移動する。
'存在しない場合カーサーはそのままとする。
'すでに検索結果を画面に表示している場合（検索結果が取り消し線のものに限らず）、その結果にも削除結果を反映する。
Private Sub STDeleteButton_Click()
    Dim lngNumOfResult As Long                      '取り消し線の削除結果の数。この結果はListView1に反映しないため、本関数内のみで扱う。
    
    Application.ScreenUpdating = False              'DoEventsを実施すると書き換え発生のため、あまり意味がない。
    
    If DeleteSTAndFindNextWCheck(ComboBox1.ListIndex, ActiveCell, lngNumOfResult) Then '現在のセルに取り消し線がある場合、削除する。
        If lngNumOfResult > 0 And G_resultType > 0 Then           '取り消し線を削除しており、なんらか検索結果がある場合、ListView1に結果を反映する。
            Call ShowResult(G_cellArray)
        End If
    End If
    
    Application.ScreenUpdating = True
End Sub

'Strikethroughタブのすべて検索ボタンを押したとき、ワークシート、もしくはワークブックを取り消し線で検索を実施する。
Private Sub STFindButton_Click()
    Call ExeFindStrikethrough(True)
End Sub

'Strikethroughタブの次を検索ボタンを押したとき、カーサーのあるセル以降に存在する、取り消し線のあるセルを確認し、そこへカーサーを移動する。
'存在しない場合カーサーはそのままとする。
'取り消し線がない場合ないことを通知する。
Private Sub STFindNextButton_Click()
    Application.ScreenUpdating = False
    
    Call FindNextStrikethroughCellWCheck(ComboBox1.ListIndex)

    Application.ScreenUpdating = True
End Sub

'キャンセルボタンを押したとき、画面をクローズする。
Private Sub CancelBtn_Click()
    Unload FindForm
End Sub

'ListView1がダブルクリックされる場合、そこで選択されたセルにカーサーを移動する。
Private Sub ListView1_DblClick()
    Call JumpSelectedLink
End Sub

'取り消し線で検索を実施する。
'
'@bShowResult Boolean 結果出力を表示するかを示す。Trueの場合表示する。Falseの場合表示しない。
Private Sub ExeFindStrikethrough(bShowResult As Boolean)
    Application.ScreenUpdating = False
    
    If FindStrikethroughWCheck(ComboBox1.ListIndex, G_cellArray, G_numOfResult) Then           '正常にFontClor検索処理が終わる場合
        If G_numOfResult > 0 Then               '見つかったセルが1つ以上の場合
            If bShowResult Then
                Call ShowResult(G_cellArray)              '結果を出力
                G_resultType = STRIKETHROUGH_TYPE
            End If
        Else
            ListView1.ListItems.Clear
            G_resultType = 0
        End If
    End If
    Application.ScreenUpdating = True
End Sub

'CellArray()のセル情報をListView1に表示する。
'
'@CellArray() Range セル情報の配列。
Private Sub ShowResult(CellArray() As Range)
    Dim lngNo As Long
    
    ListView1.ListItems.Clear
    For lngNo = 1 To UBound(CellArray)
        With ListView1.ListItems.Add
            .Text = CellArray(lngNo).Parent.Name
            .SubItems(1) = CellArray(lngNo).Address
            .SubItems(2) = CellArray(lngNo).Text
        End With
    Next
End Sub

'ListView1がダブルクリックされる場合、そこで選択されたセルにカーサーを移動する。
Private Sub JumpSelectedLink()
    If Not ListView1.SelectedItem Is Nothing Then   '選択されている場合だけ処理する。
        With ListView1.SelectedItem
            If Worksheets(.Text).Visible Then
                Worksheets(.Text).Select
                Worksheets(.Text).Range(.SubItems(1)).Select
            Else
                MsgBox (ERR_MSG_01)
            End If
        End With
    End If
End Sub

ソースコードの説明です。

Windows API定数宣言、Windows API宣言は、Excel VBA 第5回 Win32APIの取り込みと64bit対応とフォームのサイズ変更あたりを参照ください。

Constant

FONT_COLOR_TYPEとSTRIKETHROUGH_TYPEは、検索結果がどちらに該当するかをしめすために追加した定数です。
ERR_MSG_01は、シートが非表示されていた場合のエラー表示のための定数です。

Global variable

G_resultTypeは、フォントの検索結果と取り消し線の検索結果かのどちらかを示す。結果がない場合は0です。
G_cellArrayは、検索結果のセルを含む配列です。Unionを使わずに配列です。
セル情報がシートをまたぐからで、Unionでは同一シート内しか範囲を結合できないために配列にしています。
G_numOfResultは、検索、削除した結果の数です。G_cellArrayの配列数とはちょっと違う使い方をしており、あえて作りました。それはG_numOfResultは、検索した結果を示しており、検索後（例えば5つの結果）、取り消し線を削除したときに実際に削除した数（例えば３つの結果）というように検索の結果と実際の削除の結果が違うことを想定しました。
別途削除結果のG_cellArrayを作ってもよいのですが、今のところ作っていません。

Function

UserForm_Initialize

FindFormを初期化するときに実行されます。
ComboBoxを追加するのと、MultiPanelは、最初のシートにすること、結果の欄は削除して初期化することを実施します。

FontColorBtn_Click

Findタブの文字色ボタンを押したときに実行されます。
文字色検索を実施するためのマクロです。中身はシンプルで、FindFontColorWCheckを実行すると文字色選択して結果が戻ってくるため、その結果でセルが見つかった場合は、結果を表示します。結果が見つからない場合は、ListViewをクリアします。（過去の検索結果がきえるということです）
Application.ScreenUpdatingをFalseとTrueにすることで、画面描画を止めていますが、Cls_ProgressBarクラスを使用しており、そこで進捗バーを表示して更新するのに、DoEventsを入れており、画面更新は発生しているため、あまり意味がないかなとは思っています。

StrikethroughBtn_Click

Findタブの取り消し線ボタンを押したときに実行されます。
FindタブとStrikethroughタブで共通のFunctionを使うため、別の関数にしました。
ExeFindStrikethroughのところで説明します。

STDeleteAllButton_Click

Strikethroughタブの全削除ボタンを押したときに実行されます。
Excelの置換では、「全置換」を押すと、すでに検索結果があっても、再検索したうえで、見つかったものを置換するようですが、今回の実装では検索結果があった場合は、検索結果に基づき、取り消し線を削除し、検索結果がない場合は、検索したうえで削除します。
こうした理由としては、取り消し線があるかを検索する場合、セル内の一文字づつフォントを確認して取り消し線があるかを確認しますが、この処理がとても時間がかかります。
そのため、検索結果がすでにあるならば、再度検索をするのはやめようと思いそうしました。
そのため、ソースでは、G_resultTypeがSTRIKETHROUGH_TYPEかそうでないかを判定して処理を実行しています。
STRIKETHROUGH_TYPEは、取り消し線の検索を行った場合に設定される定数です。
そうでない場合は、現時点では検索していないか、文字色検索の結果がある場合です。
文字色の結果がある状態で、本ボタンを押すと、取り消し線を探したうえで、削除します。見つかった中に文字色検索のセルがある場合は、その検索結果も更新するという処理をしています。
ちょっと変な実装なのですが、Excelもそうなっているようなので、それをまねました。

STDeleteButton_Click

Strikethroughタブの削除ボタンを押したときに実行されます。
このボタンを押したときにあるカーサーの位置のセルの取り消し線があるか確認し、存在する場合は取り消し線を削除し、次の取り消し線のあるセルを探します。

STFindButton_Click

Strikethroughタブのすべて検索ボタンを押したときに実行されます。
ExeFindStrikethroughのところで説明します。

STFindNextButton_Click

Strikethroughタブの次へボタンを押したときに実行されます。これも関数化しているため、別で説明します。

CancelBtn_Click

キャンセルボタンを押したときに、FindFormをクローズします。

ListView1_DblClick

ListView1がダブルクリックされたときに実行されます。
JumpSelectedLinkのところで説明します。

ExeFindStrikethrough

取り消し線ボタンをおしたときに実行されます。
取り消し線のあるセルを検索します。検索してセルが見つかれば、検索結果をListViewに表示し、見つからない場合は過去の検索結果は削除します。

ShowResult

検索結果を表示するための関数です。

JumpSelectedLink

ListViewがダブルクリックされたとき、ListView内の結果の該当のセルにカーサーを移動します。
結果がない場合はなにもしません。
また、該当セルのシートが非表示の場合は、非表示シートであることを通知します。

文字色選択の画面作成

文字色選択の画面は、Excelの標準ダイアログ(Application.Dialogs)のパターンを使用します。
ExcelのApplication.Dialogsはいくつか種類があり、Fontのダイアログ(xlDialogFont)は存在しますが、文字色以外にフォント名。スタイル、サイズなどその他の設定が多く存在するためわかりづらいことと、その設定値を取得するのが難しいため、背景色を設定するパターン(xlDialogPatterns)を使うことにしました。
背景色選択画面は、もともと背景色を選択するものであるため、ユーザーが誤解する可能性があること、「塗りつぶしの効果」を設定可能なため、色だけを選択しない可能性もあることといった点で、完璧ではなく、ユーザーの理解を必要とする実装ですが、文字色選択画面よりはオプションが少ないのでいいのかなとは思います。

この背景色選択画面は、検索するワークブックではなく、別のワークブックを新たに開き、そこで表示をさせます。そのワークブックは背景色を取得した後（文字色を選択した後）削除します。
これは、検索するワークブックで実施すると、以下の課題があるためです。
・そのワークブックのカーサーのある場所のセルの背景色がかわってしまう。
・そのワークブックのカーサーの場所の背景色を変えた後をもとに戻す必要がある。
・そのワークブックを編集したことになり、その後ワークブックを閉じるとき保存するかを聞かれてしまう。

ソースコードは、以下です。

Cls_ColorPatterns.cls

Option Explicit

'-----Constant-----

'-----Global variable-----
Private G_clsErr As Cls_Error
Private G_wb As Workbook    '背景色選択画面表示のために使用するテンポラリのWorkbook
Private G_color As Long
Private G_colorIndex As Long
Private G_bScreenUpdating As Boolean
Private G_activeWb As Workbook    'もともとのActiveWorkbookを設定。

'-----Property-----
'背景色選択画面で設定した色のColorを取得する。
Public Property Get Color() As Long
    Color = G_color
End Property

'背景色選択画面で設定した色のColorIndexを取得する。
Public Property Get ColorIndex() As Long
    ColorIndex = G_colorIndex
End Property

'-----Class Initialize-----
Private Sub Class_Initialize()
End Sub

'------Function-----
'クラスを初期化する。
'対象のワークブック設定と、エラークラスのインスタンスを設定する。
'
'@ClsErr Cls_Error エラークラスのインスタンス。
Public Function InitializeClass(ClsErr As Cls_Error)
    G_bScreenUpdating = Application.ScreenUpdating
    Application.ScreenUpdating = False
    Set G_wb = Workbooks.Add
    G_wb.Worksheets.Add
    ActiveWindow.Visible = False
    Set G_clsErr = ClsErr
End Function

'本クラスのデストラクタ。
'背景色選択画面のために開いたWorkbookを閉じる。
Private Sub Class_Terminate()
    G_wb.Close (False)
    Set G_wb = Nothing
    Application.ScreenUpdating = G_bScreenUpdating    'ScreenUpdatingを元の状態に戻す。
End Sub

'Excelの標準の背景色選択画面画面を開いて文字色を選択する。
'選択した場合True、キャンセルした場合False。
'文字色パレットを使用すると背景色が変更される。その背景色を取得することで、選択した色を取得する。
'
'@return Boolean 選択した場合True、キャンセルした場合False。
Public Function SelectBgColor() As Boolean
    
    On Error GoTo AnyErr
    
    Set G_activeWb = ActiveWorkbook
    
    G_wb.Activate                                               '背景色選択画面を開くWorkbookをActivateする。
    If (Application.Dialogs(xlDialogPatterns).Show = 0) Then    '背景色選択画面を開きキャンセルした場合、処理をキャンセルする。
        SelectBgColor = False
        Exit Function
    End If
    
    G_color = ActiveCell.Interior.Color
    G_colorIndex = ActiveCell.Interior.ColorIndex
    
    G_activeWb.Activate
    SelectBgColor = True
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("ColorPatterns", "SelectBgColor")
    Call G_clsErr.ShowErrMsg
End Function

Global variable

G_wb, g_activeWb

G_wbは、背景色選択画面用を表示するためのワークブックです。
G_activeWbは、検索を実施するワークブックです。
背景色選択画面で文字色を選択した後、ActiveWorkbookに戻すために保持します。

G_color, G_colorIndex

文字色のColorとColorIndexの値を保持します。

G_bScreenUpdating

G_bScreenUpdatingは、Application.ScreenUpdatingの状態を保持します。このクラスを実行時には一時的にApplication.ScreenUpdatingをFalseにします。文字色取得後に、もとのScreenUpdatingに戻すために、値を保持します。

Property

ColorとColorIndexを取り出せるようにしました。

Function

InitializeClass

クラスを初期化します。
現在のScreenUpdatingの値を取得しつつ、まずScreenUpdatingをFalseにします。
その後は、新しいワークブックを追加し、非表示にします。
別のワークブックを開いていることがわからないようにするためです。こうすると、背景色選択画面は表示されても、ワークブック自体は表示されません。

Class_Terminate

クラスを解放したときの処理です。
新たに開いたワークブックを閉じつつ、ScreenUpdatingをクラスを使う前の状態に戻します。

SelectBgColor

背景色選択画面を開いて色を選択する関数です。
Application.Dialogs(xlDialogPatterns).Showで、背景色選択画面を開くことができます。戻り値は、OKを押すとTrue、キャンセルを押すとFalseになるため、If文でOKの場合、そのセルの背景色を取得するようにしました。

CreateObjectの追加

一部の修正です。

CreateObject.bas

Option Explicit

Public G_clsErr As Cls_Error

'Cls_Errorクラスのインスタンスを作成する関数。
'プロジェクト名とバージョンを初期化する。
'
'@ProjName String プロジェクト名。
'@Version String ツールバージョン。
'@return Cls_Error Cls_Errクラスのインスタンス。
Public Function CreateErrClass(ProjName As String, Version As String) As Cls_Error
    Set CreateErrClass = New Cls_Error
    Call CreateErrClass.SetProject(ProjName, Version)
End Function


'Cls_VisibleSheetsクラスのインスタンスを作成する関数。
'
'@Wb Workbook 対象のワークブック。
'ClsErr Cls_Error エラークラスのインスタンス。
'@return Cls_VisibleSheets Cls_VisibleSheetsクラスのインスタンス。
Public Function CreateVisibleSheetsClass(Wb As Workbook, ClsErr As Cls_Error) As Cls_VisibleSheets
    Set CreateVisibleSheetsClass = New Cls_VisibleSheets
    Call CreateVisibleSheetsClass.InitializeClass(Wb, ClsErr)
End Function

'Cls_ColorPatternsクラスのインスタンスを作成する関数。
'
'ClsErr Cls_Error エラークラスのインスタンス。
'@return Cls_ColorPatterns Cls_ColorPatternsクラスのインスタンス。
Public Function CreateColorPatternsClass(ClsErr As Cls_Error) As Cls_ColorPatterns
    Set CreateColorPatternsClass = New Cls_ColorPatterns
    Call CreateColorPatternsClass.InitializeClass(ClsErr)
End Function

CreateColorPatternsClass

上記クラスの背景色選択画面を開くクラスを初期化する関数を追加しました。

Ribbonの追加

OrgMacroのリボン上に検索用のボタンを追加します。
ソースコードは、OrgMacro.xlamの拡張子をZipに変更して解凍したcustomUI.xmlにあります。詳しくは、Excel VBA 第2回リボンとアドイン作成を参照。
ソースコードは、以下です。

customUI.xml

<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
    <ribbon startFromScratch="false">
      <tabs>
        <tab id="Tab" label="OrgMacro">
            <group id="activeA1group" label="Origin">
				<splitButton id="orgSplitBtn" size="large">
					<button id="activeA1wZoom100" label="ActiveA1wZoom100" imageMso="A" onAction="R_ActiveA1wZoom100"/>
					<menu id="splitMenu" itemSize="large">
					<button id="activeA1wZoom100_2" label="ActiveA1wZoom100" imageMso="A" onAction="R_ActiveA1wZoom100"/>
					<button id="activeA1" label="ActiveA1" imageMso="A" onAction="R_ActiveA1"/>
					</menu>
				</splitButton>
            </group>
			<group id="findgroup" label="Find">
				<button id="find" label="Find" size="large" imageMso="GroupFind" onAction="R_ShowFindForm"/>
			</group>
        </tab>
      </tabs>
    </ribbon>
</customUI>

今回追加したのは、findgroupのところで、labelはFindにし、imageMsoはGroupFindを使って、検索アイコンを作りました。

また、このためにRibbon.basにもソースを追加しました。

ribbon.bas

Option Explicit

Public Sub R_ActiveA1(control As IRibbonControl)
    Call M_ActiveA1AllSheets
End Sub

Public Sub R_ActiveA1wZoom100(control As IRibbonControl)
    Call M_ActiveA1wZoom100AllSheets
End Sub

Public Sub R_ShowFindForm(control As IRibbonControl)
    Call M_ShowFindForm
End Sub

R_ShowFindForm関数を作りました。中身は、M_ShowFindFormを実行するだけです。この関数は、Find.basで定義されます。

エラー表示用の定数の追加

以下のソースコードで、ERR_MSG_01~05を追加しました。

constant.bas

Option Explicit

Public Const PROJ_NAME As String = "orgMacro"

Public Const A1_ERR_MSG1 As String = "シートが保護されている可能性があります。恐れ入りますが、処理できませんでした。"
Public Const ERR_MSG_01 As String = "対象のワークブックが見つかりません。"
Public Const ERR_MSG_02 As String = "対象のワークシートが見つかりません。"
Public Const ERR_MSG_03 As String = "一致するデータが見つかりません。"
Public Const ERR_MSG_04 As String = "保護シートがあります。"
Public Const ERR_MSG_05 As String = "非表示シートがあります。そこに対象のセルがある可能性があります。"

検索処理の追加

Find.basが検索処理のメインです。
ここは関数が多くなりましたが、文字色検索関連、取り消し線検索関連、取り消し線削除関連でそれぞれ関数を作りました。
同じ記載が多くなったため、もう少しまとめたほうが良かったかもしれませんが、現状は分かれています。
ソースコードは以下です。

Find.bas

Option Explicit

'-----Constant-----

'-----Global variable-----
Private G_PBar As Cls_ProgressBar
Private G_cellArray() As Range      '検索実行した結果のセルの配列。Unionではシート間をまたげないため、配列を使用。
Private G_lngNumOfResult As Long    '実行した結果のセルの数。現時点では取り消し線で削除した数。
'-----Property-----

'-----Function-----

'オリジナル検索用のウィンドウを開く。
Public Sub M_ShowFindForm()
    Call FindForm.Show(vbModeless)
End Sub

'-----文字色関連Function------

'背景色のカラーパレットを表示し、色を選択したうえで、その色をFontのColorとして、
'ワークブックやワークシートのセルからそのColorを検索し、CellArrayに応答する。
'
'@lngMode Long シート単位(0)かブック単位(1)かを設定する。
'@CellArray() Range 検索結果のセルの配列を出力する。
'@lngNumOfResult Long 検索結果のセルの数を出力する。
'@return Boolean 正常にサーチが終了する場合True、そうでない場合False。
Public Function FindFontColorWCheck(lngMode As Long, CellArray() As Range, lngNumOfResult As Long) As Boolean
    Dim ClsColorPatterns As Cls_ColorPatterns
    Dim lngColor As Long
    
    Set G_clsErr = CreateErrClass(PROJ_NAME, VER)   'エラークラス(Cls_Error)のインスタンス生成
    
    On Error GoTo AnyErr
    
    If Not ExistsWorkbookWorksheet(ActiveWorkbook) Then         'ワークブックとワークシートの有無を確認。ない場合は処理終了。
        FindFontColorWCheck = False
        Exit Function
    End If
    
    If lngMode = 0 Then                                         'lngModeが0(シート)の場合
        If Not IsActiveWorkSheet(ActiveSheet.Type) Then              'ActiveSheetがワークシートでない場合処理終了。
            FindFontColorWCheck = False
            Exit Function
        End If
    End If
    
    Call ProtectUserInterfaceOnly                   '保護されているシートについて、マクロで動作するように設定を変更。
    
    Set ClsColorPatterns = CreateColorPatternsClass(G_clsErr)   'カラーパレットクラス(Cls_ColorPatterns)のインスタンス生成
    
    If Not ClsColorPatterns.SelectBgColor Then       '文字色を選択する画面を表示し、応答がFalse（文字色選択を中断する）の場合、処理を終了する。
        Set ClsColorPatterns = Nothing
        FindFontColorWCheck = False
        Exit Function
    End If
    
    lngColor = ClsColorPatterns.Color
    Set ClsColorPatterns = Nothing
    
    FindFontColorWCheck = FindFontColorWPBar(lngMode, lngColor, CellArray)
    lngNumOfResult = UBound(CellArray)
    If lngNumOfResult = 0 Then
        MsgBox (ERR_MSG_03)
    End If
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "FindFontColorWCheck")
    Call G_clsErr.ShowErrMsg
End Function

'ワークシートやワークブックからlngColorの色の文字を探して、CellArrayにセル情報（シート名、アドレス、値）を応答する。
'正常の場合True、見つからない場合False。
'本処理は、ProgressBarを使用して進捗を表示する。そのため、本関数の内容はProgressBarの初期設定のみである。
'実態は、FindFontColorWSheetLoopやFindFontColorWAllSheetsLoopで実行する。
'
'@lngMode Long シート単位(0)かブック単位(1)かを設定する。
'@lngColor Long 検索する文字色。
'@CellArray() Range 検索結果のセルの配列を出力する。
'@return Boolean 正常に終了する場合True、そうでない場合False。
Private Function FindFontColorWPBar(lngMode As Long, lngColor As Long, CellArray() As Range) As Boolean
    Dim strFuncName As String
    Dim params() As Variant
    Dim lngNo As Long
    Dim bSelectOK As Boolean
    
    On Error GoTo AnyErr
    
    strFuncName = "FindFontColor"
    ReDim params(1)
    params(1) = lngColor
    
    Call PBarInitialize(lngMode, strFuncName, params)
    
    If UBound(G_cellArray) >= 1 Then    '結果が1つ以上存在する場合、最初のセルを選択。
        For lngNo = 1 To UBound(G_cellArray)
            If G_cellArray(lngNo).Parent.Visible Then
                G_cellArray(lngNo).Parent.Select    'シートを選択。
                G_cellArray(lngNo).Select           'セルを選択。
                bSelectOK = True
            End If
        Next
        If Not bSelectOK Then   '非表示のためすべて選択できなかった場合エラー表示。
            MsgBox (ERR_MSG_05)
        End If
    End If
    
    CellArray = G_cellArray '結果をCellArrayに設定。

    FindFontColorWPBar = True
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "FindFontColorWPBar")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'ワークシートからlngColorの色の文字を探して、CellArrayにセル情報（シート名、アドレス、値）をG_cellArrayに設定する。
'
'@p() Variant 中身は、p(0)は検索対象のワークシート、p(1)はlngColorで検索する文字色のLong値。
Public Sub FindFontColorWSheetLoop(p() As Variant)
    Dim lngColor As Long
    Dim Ws As Worksheet
    Dim Cell1 As Range
    
    On Error GoTo AnyErr
    
    lngColor = p(1)
    Set Ws = p(0)
    For Each Cell1 In Ws.UsedRange
        If G_PBar.StopFunc Then Exit Sub
        If IsFontColor(Cell1, lngColor) Then
            Call AddCellInfo(Cell1)
        End If
    
        G_PBar.Value = G_PBar.Value + 1
    Next
    
    Exit Sub
AnyErr:
    Call G_clsErr.SetError("Find", "FindFontColorWSheetLoop")
    Call G_clsErr.ShowErrMsg
End Sub

'ワークブックからColorの色の文字を探して、CellArrayにセル情報（シート名、アドレス、値）をG_cellArrayに設定する。
'
'@p() Variant 中身は、p(0)は検索対象のワークブック。lngColorで検索する文字色のLong値。
Public Sub FindFontColorWAllSheetsLoop(p() As Variant)
    Dim lngColor As Long
    Dim Wb As Workbook
    Dim Ws As Worksheet
    Dim newP() As Variant
    
    On Error GoTo AnyErr
    
    Set Wb = p(0)   'ワークブック
    ReDim newP(1)
    newP(1) = p(1)  'lngColorの設定
    For Each Ws In Wb.Worksheets
        Set newP(0) = Ws    'ワークシートの設定
        Call FindFontColorWSheetLoop(newP)
    Next
    
    Exit Sub
AnyErr:
    Call G_clsErr.SetError("Find", "FindFontColorWAllSheetsLoop")
    Call G_clsErr.ShowErrMsg
End Sub

'Cell1のCharacter内にlngColorの値があるか確認する。
'存在する場合、Trueを返し、そうでない場合Falseを返す。
'
'@Cell1 Range 対象のセル。
'@lngCplor Long 対象の色の値。
'@return Boolean 存在する場合True、そうでない場合False。
Private Function IsFontColor(Cell1 As Range, lngColor As Long) As Boolean
    Dim lngNo As Long

    On Error GoTo AnyErr
    
    'lngColorの値チェックは、ここではしない。別途必要に応じて実施する可能性あり。
    
    If IsNull(Cell1.Font.Color) Then    'セルのFont.ColorがNullの場合（文字ごとにFont.Colorが設定されている可能性がある場合はNullになる。）
        For lngNo = 1 To Len(Cell1.Value)
            If Cell1.Characters(lngNo, 1).Font.Color = lngColor Then
                IsFontColor = True
                Exit Function
            End If
        Next
    ElseIf Cell1.Font.Color = lngColor Then 'セルのFont.ColorがNullでない場合（セルの全体のFont.Colorがひとつ設定されている場合）
       IsFontColor = True
    End If
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "IsFontColor")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'-----取り消し線の検索関連Function------

'ワークシートやワークブックから取り消し線のある文字を検索し、CellArrayに応答する。
'
'@lngMode Long シート単位(0)かブック単位(1)かを設定する。
'@CellArray() Range 検索結果のセルの配列を出力する。
'@lngNumOfResult Long 検索結果のセルの数を出力する。
'@return Boolean 正常にサーチが終了する場合True、そうでない場合False。
Public Function FindStrikethroughWCheck(lngMode As Long, CellArray() As Range, lngNumOfResult As Long) As Boolean
    
    Set G_clsErr = CreateErrClass(PROJ_NAME, VER)   'エラークラス(Cls_Error)のインスタンス生成

    On Error GoTo AnyErr

    If Not ExistsWorkbookWorksheet(ActiveWorkbook) Then             'ワークブックとワークシートの有無を確認。ない場合は処理終了。
        FindStrikethroughWCheck = False
        Exit Function
    End If
    
    If lngMode = 0 Then                                         'lngModeが0(シート)の場合
        If Not IsActiveWorkSheet(ActiveSheet.Type) Then              'ActiveSheetがワークシートでない場合処理終了。
            FindStrikethroughWCheck = False
            Exit Function
        End If
    End If
    
    Call ProtectUserInterfaceOnly                   '保護されているシートについて、マクロで動作するように設定を変更。

    FindStrikethroughWCheck = FindStrikethroughPBar(lngMode, CellArray)
    lngNumOfResult = UBound(CellArray)
    If lngNumOfResult = 0 Then
        MsgBox (ERR_MSG_03)
    End If
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "FindStrikethroughWCheck")
    Call G_clsErr.ShowErrMsg
End Function

'ワークシートやワークブックから取り消し線のある文字を検索し、CellArrayにセル情報（シート名、アドレス、値）を応答する。
'正常の場合True、見つからない場合False。
'本処理は、ProgressBarを使用して進捗を表示する。そのため、本関数の内容はProgressBarの初期設定のみである。
'実態は、FindStrikethroughSheetLoopやFindStrikethroughWAllSheetsLoopで実行する。
'
'@lngMode Long シート単位(0)かブック単位(1)かを設定する。
'@CellArray() Range 検索結果のセルの配列を出力する。
'@return Boolean 正常に終了する場合True、そうでない場合False。
Private Function FindStrikethroughPBar(lngMode As Long, CellArray() As Range) As Boolean
    Dim strFuncName As String
    Dim params() As Variant
    Dim lngNo As Long
    Dim bSelectOK As Boolean
    
    On Error GoTo AnyErr
    
    strFuncName = "FindStrikethrough"
    ReDim params(0)
    
    Call PBarInitialize(lngMode, strFuncName, params)

    If UBound(G_cellArray) >= 1 Then    '結果が1つ以上存在する場合、最初のセルを選択。
        For lngNo = 1 To UBound(G_cellArray)
            If G_cellArray(lngNo).Parent.Visible Then
                G_cellArray(lngNo).Parent.Select    'シートを選択。
                G_cellArray(lngNo).Select           'セルを選択。
                bSelectOK = True
            End If
        Next
        If Not bSelectOK Then   '非表示のためすべて選択できなかった場合エラー表示。
            MsgBox (ERR_MSG_05)
        End If
    End If
    
    CellArray = G_cellArray '結果をCellArrayに設定。
    
    FindStrikethroughPBar = True
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "FindStrikethroughPBar")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'ワークシートから取り消し線のある文字を探して、CellArrayにセル情報（シート名、アドレス、値）をG_cellArrayに設定する。
'
'@p() Variant 中身は、p(0)は検索対象のワークシート。
Public Sub FindStrikethroughWSheetLoop(p() As Variant)
    Dim Ws As Worksheet
    Dim Cell1 As Range
    
    On Error GoTo AnyErr
    
    Set Ws = p(0)
    For Each Cell1 In Ws.UsedRange
        If G_PBar.StopFunc Then Exit Sub
        If IsStrikethrough(Cell1) Then
            Call AddCellInfo(Cell1)
        End If
    
        G_PBar.Value = G_PBar.Value + 1
    Next
    Exit Sub
AnyErr:
    Call G_clsErr.SetError("Find", "FindStrikethroughWSheetLoop")
    Call G_clsErr.ShowErrMsg
End Sub

'ワークブックから取り消し線のある文字を探して、CellArrayにセル情報（シート名、アドレス、値）をG_cellArrayに設定する。
'
'@p() Variant 中身は、p(0)は検索対象のワークブック。
Public Sub FindStrikethroughWAllSheetsLoop(p() As Variant)
    Dim Wb As Workbook
    Dim Ws As Worksheet
    Dim newP() As Variant
    
    On Error GoTo AnyErr
    
    Set Wb = p(0)
    ReDim newP(0)
    For Each Ws In Wb.Worksheets
        Set newP(0) = Ws
        Call FindStrikethroughWSheetLoop(newP)
    Next
    
    Exit Sub
AnyErr:
    Call G_clsErr.SetError("Find", "FindStrikethroughWAllSheetsLoop")
    Call G_clsErr.ShowErrMsg
End Sub

'Cell1のCharacter内に取り消し線があるか確認する。
'存在する場合、Trueを返し、そうでない場合Falseを返す。
'
'@Cell1 Range 対象のセル。
'@return Boolean 存在する場合True、そうでない場合False。
Private Function IsStrikethrough(Cell1 As Range) As Boolean
    Dim lngNo As Long

    On Error GoTo AnyErr
    
    If IsNull(Cell1.Font.Strikethrough) Then    'セルのFont.StrikethroughがNullの場合（文字ごとにFont.Strikethroughが設定されている可能性がある場合はNullになる。）
        For lngNo = 1 To Len(Cell1.Value)
            If Cell1.Characters(lngNo, 1).Font.Strikethrough Then
                IsStrikethrough = True
                Exit Function
            End If
        Next
    ElseIf Cell1.Font.Strikethrough Then        'セルのFont.StrikethroughがNullでない場合（セルの全体のFont.Strikethroughがひとつ設定されている場合）
       IsStrikethrough = True
    End If
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "IsStrikethrough")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'-----取り消し線の全削除関連Function------

'ワークシートやワークブックから、CellArray配列内の取り消し線の文字をすべて削除する。
'
'@lngMode Long シート単位(0)かブック単位(1)かを設定する。
'@CellArray() Range 検索結果のセルの配列を出力する。
'@lngNumOfResult Long 検索結果のセルの数を出力する。
'@return Boolean 正常に削除終了する場合True、そうでない場合False。
Public Function DeleteStrikethroughWCheck(lngMode As Long, CellArray() As Range, lngNumOfResult As Long) As Boolean
    
    Set G_clsErr = CreateErrClass(PROJ_NAME, VER)   'エラークラス(Cls_Error)のインスタンス生成
    
    If Not ExistsWorkbookWorksheet(ActiveWorkbook) Then         'ワークブックとワークシートの有無を確認。ない場合は処理終了。
        DeleteStrikethroughWCheck = False
        Exit Function
    End If
    
    If lngMode = 0 Then                                         'lngModeが0(シート)の場合
        If Not IsActiveWorkSheet(ActiveSheet.Type) Then              'ActiveSheetがワークシートでない場合処理終了。
            DeleteStrikethroughWCheck = False
            Exit Function
        End If
    End If
    
    If ExistsProtectWorksheet(lngMode, True) Then         '保護シートがある場合処理終了。
        DeleteStrikethroughWCheck = False
        Exit Function
    End If

    
    DeleteStrikethroughWCheck = DeleteStrikethroughPBar(lngMode, CellArray, lngNumOfResult)
    If lngNumOfResult = 0 Then
        MsgBox (ERR_MSG_03)
    End If
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "DeleteStrikethroughWCheck")
    Call G_clsErr.ShowErrMsg
End Function

'ワークシートやワークブックから検索結果CellArray配列内の取り消し線の文字を削除する。
'正常の場合True、見つからない場合False。
'本処理は、ProgressBarを使用して進捗を表示する。そのため、本関数の内容はProgressBarの初期設定のみである。
'実態は、DeleteStrikethroughWSheetLoopやDeleteStrikethroughWAllSheetsLoopで実行する。
'
'@lngMode Long シート単位(0)かブック単位(1)かを設定する。
'@CellArray() Range 取り消し線の結果を含むCellArray。出力にも利用する。
'@lngNumOfResult Long 検索結果のセルの数を出力する。
'@return Boolean 正常に終了する場合True、そうでない場合False。
Private Function DeleteStrikethroughPBar(lngMode As Long, CellArray() As Range, lngNumOfResult As Long) As Boolean
    Dim strFuncName As String
    Dim params() As Variant
    Dim lngMaxNum As Long
    
    On Error GoTo AnyErr
    
    strFuncName = "DeleteStrikethrough"
    ReDim params(1)
    params(1) = CellArray
    
    lngMaxNum = UBound(CellArray)
    
    Call PBarInitialize(lngMode, strFuncName, params, lngMaxNum)
    
    CellArray = G_cellArray '結果をCellArrayに設定。
    lngNumOfResult = G_lngNumOfResult
    
    DeleteStrikethroughPBar = True
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "DeleteStrikethroughPBar")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'CellArray配列の現在のワークシートのセルから取り消し線のある文字を探して削除する。
'
'@p() Variant 中身は、p(0)は検索対象のワークシート、p(1)はCellArrayの配列。
Public Sub DeleteStrikethroughWSheetLoop(p() As Variant)
    Dim lngNo As Long
    Dim Ws As Worksheet
    Dim CellArray() As Range
    
    On Error GoTo AnyErr
    
    Set Ws = p(0)
    CellArray = p(1)
    G_lngNumOfResult = 0   'いったん過去の結果を削除し、0にする。
    For lngNo = 1 To UBound(CellArray)
        If G_PBar.StopFunc Then Exit Sub
        If CellArray(lngNo).Parent.Name = Ws.Name Then
            If DeleteStrikethrough(CellArray(lngNo)) Then G_lngNumOfResult = G_lngNumOfResult + 1
        End If
        G_PBar.Value = G_PBar.Value + 1
    Next
    G_cellArray = CellArray
    
    Exit Sub
AnyErr:
    Call G_clsErr.SetError("Find", "DeleteStrikethroughWSheetLoop")
    Call G_clsErr.ShowErrMsg
End Sub

'CellArray配列のすべてのシートのセルから取り消し線のある文字を探して削除する。
'
'@p() Variant 中身は、p(0)は検索対象のワークブック。p(1)はCellArrayの配列。
Public Sub DeleteStrikethroughWAllSheetsLoop(p() As Variant)
    Dim lngNo As Long
    Dim CellArray() As Range

    On Error GoTo AnyErr

    CellArray = p(1)
    For lngNo = 1 To UBound(CellArray)
        If G_PBar.StopFunc Then Exit Sub
        Call DeleteStrikethrough(CellArray(lngNo))
        G_PBar.Value = G_PBar.Value + 1
    Next
    G_cellArray = CellArray

    Exit Sub
AnyErr:
    Call G_clsErr.SetError("Find", "DeleteStrikethroughWAllSheetsLoop")
    Call G_clsErr.ShowErrMsg
End Sub

'Cell1のCharacter内に取り消し線があるか確認し、存在する場合その文字を削除する。
'存在する場合、Trueを返し、そうでない場合Falseを返す。
'
'@Cell1 Range 入力/出力。対象のセル。
'@return Boolean 存在する場合その文字を削除しTrue、そうでない場合False。
Public Function DeleteStrikethrough(Cell1 As Range) As Boolean
    Dim lngNo As Long

    On Error GoTo AnyErr
    
    If IsNull(Cell1.Font.Strikethrough) Then    'セルのFont.StrikethroughがNullの場合（文字ごとにFont.Strikethroughが設定されている可能性がある場合はNullになる。）
        For lngNo = Len(Cell1.Value) To 1 Step -1
            If Cell1.Characters(lngNo, 1).Font.Strikethrough Then
                DeleteStrikethrough = True
                Cell1.Characters(lngNo, 1).Delete
            End If
        Next
    ElseIf Cell1.Font.Strikethrough Then        'セルのFont.StrikethroughがNullでない場合（セルの全体のFont.Strikethroughがひとつ設定されている場合）
       DeleteStrikethrough = True
       Cell1.Value = ""
       Cell1.Font.Strikethrough = False
    End If
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "DeleteStrikethrough")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'-----取り消し線検索＆削除関連Function------

'ワークシートやワークブックから取り消し線のある文字を検索し、取り消し線の文字を削除する。
'
'@lngMode Long シート単位(0)かブック単位(1)かを設定する。
'@CellArray() Range 検索結果のセルの配列を出力する。
'@lngNumOfResult Long 検索結果のセルの数を出力する。
'@return Boolean 正常に削除終了する場合True、そうでない場合False。
Public Function FindDeleteStrikethroughWCheck(lngMode As Long, CellArray() As Range, lngNumOfResult) As Boolean
    
    Set G_clsErr = CreateErrClass(PROJ_NAME, VER)   'エラークラス(Cls_Error)のインスタンス生成
    
    If Not ExistsWorkbookWorksheet(ActiveWorkbook) Then             'ワークブックとワークシートの有無を確認。ない場合は処理終了。
        FindDeleteStrikethroughWCheck = False
        Exit Function
    End If
    
    If lngMode = 0 Then                                         'lngModeが0(シート)の場合
        If Not IsActiveWorkSheet(ActiveSheet.Type) Then              'ActiveSheetがワークシートでない場合処理終了。
            FindDeleteStrikethroughWCheck = False
            Exit Function
        End If
    End If
    
    If ExistsProtectWorksheet(lngMode, True) Then         '保護シートがある場合処理終了。
        FindDeleteStrikethroughWCheck = False
        Exit Function
    End If
    
    FindDeleteStrikethroughWCheck = FindDeleteStrikethroughPBar(lngMode, CellArray)
    lngNumOfResult = UBound(CellArray)
    If lngNumOfResult = 0 Then
        MsgBox (ERR_MSG_03)
    End If
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "FindDeleteStrikethroughWCheck")
    Call G_clsErr.ShowErrMsg
End Function

'ワークシートやワークブックから取り消し線の文字を検索し、削除する。
'正常の場合True、見つからない場合False。
'本処理は、ProgressBarを使用して進捗を表示する。そのため、本関数の内容はProgressBarの初期設定のみである。
'実態は、FindDeleteStrikethroughWSheetLoopやFindDeleteStrikethroughAllSheetsLoopで実行する。
'
'@lngMode Long シート単位(0)かブック単位(1)かを設定する。
'@CellArray() Range 取り消し線の結果を含むCellArray。出力にも利用する。
'@return Boolean 正常に終了する場合True、そうでない場合False。
Public Function FindDeleteStrikethroughPBar(lngMode As Long, CellArray() As Range) As Boolean
    Dim strFuncName As String
    Dim params() As Variant
    Dim lngMaxNum As Long
    
    On Error GoTo AnyErr
    
    strFuncName = "FindDeleteStrikethrough"
    ReDim params(0)
    
    Call PBarInitialize(lngMode, strFuncName, params)
    
    CellArray = G_cellArray '結果をCellArrayに設定。
    
    FindDeleteStrikethroughPBar = True
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "FindDeleteStrikethroughPBar")
    Call G_clsErr.ShowErrMsg
End Function

'ワークシートから取り消し線の文字を検索し、削除する。
'
'@p() Variant 中身は、p(0)は検索対象のワークシート。
Public Sub FindDeleteStrikethroughWSheetLoop(p() As Variant)
    Dim Ws As Worksheet
    Dim Cell1 As Range
    
    On Error GoTo AnyErr
    
    Set Ws = p(0)
    For Each Cell1 In Ws.UsedRange
        If G_PBar.StopFunc Then Exit Sub
        If FindDeleteStrikethrough(Cell1) Then
            Call AddCellInfo(Cell1)
        End If
        G_PBar.Value = G_PBar.Value + 1
    Next
    
    Exit Sub
AnyErr:
    Call G_clsErr.SetError("Find", "FindDeleteStrikethroughWSheetLoop")
    Call G_clsErr.ShowErrMsg
End Sub

'ワークブックから取り消し線のある文字を探して削除する。
'
'@p() Variant 中身は、p(0)は検索対象のワークブック。
Public Sub FindDeleteStrikethroughWAllSheetsLoop(p() As Variant)
    Dim Wb As Workbook
    Dim Ws As Worksheet
    Dim newP() As Variant

    On Error GoTo AnyErr

    Set Wb = p(0)
    ReDim newP(0)
    For Each Ws In Wb.Worksheets
        Set newP(0) = Ws
        Call FindDeleteStrikethroughWSheetLoop(newP)
    Next

    Exit Sub
AnyErr:
    Call G_clsErr.SetError("Find", "FindDeleteStrikethroughWAllSheetsLoop")
    Call G_clsErr.ShowErrMsg
End Sub

'Cell1のCharacter内に取り消し線があるか確認し、存在する場合その文字を削除する。
'存在する場合、Trueを返し、そうでない場合Falseを返す。
'
'@Cell1 Range 入力/出力。対象のセル。
'@return Boolean 存在する場合True、そうでない場合False。
Public Function FindDeleteStrikethrough(Cell1 As Range) As Boolean
    Dim lngNo As Long

    On Error GoTo AnyErr
    
    If IsNull(Cell1.Font.Strikethrough) Then    'セルのFont.StrikethroughがNullの場合（文字ごとにFont.Strikethroughが設定されている可能性がある場合はNullになる。）
        For lngNo = Len(Cell1.Value) To 1 Step -1
            If Cell1.Characters(lngNo, 1).Font.Strikethrough Then
                FindDeleteStrikethrough = True
                Cell1.Characters(lngNo, 1).Delete
            End If
        Next
    ElseIf Cell1.Font.Strikethrough Then        'セルのFont.StrikethroughがNullでない場合（セルの全体のFont.Strikethroughがひとつ設定されている場合）
       FindDeleteStrikethrough = True
       Cell1.Value = ""
       Cell1.Font.Strikethrough = False
    End If
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "FindDeleteStrikethrough")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'-----現在のセル削除&次の取り消し線検索関連Function-----

'対象のセルに取り消し線がある場合、削除する。その後、次の取り消し線を検索し、存在すればそのセルへカーサーを移動する。
'
'@lngMode Long シート単位(0)かブック単位(1)かを設定する。
'@Cell1 対象のセル
'@lngNumOfResult Long 検索結果のセルの数を出力する。
'@return Boolean 正常に削除終了する場合True、そうでない場合False。
Public Function DeleteSTAndFindNextWCheck(lngMode As Long, Cell1 As Range, lngNumOfResult As Long) As Boolean
    
    Set G_clsErr = CreateErrClass(PROJ_NAME, VER)   'エラークラス(Cls_Error)のインスタンス生成
    
    If Not ExistsWorkbookWorksheet(ActiveWorkbook) Then         'ワークブックとワークシートの有無を確認。ない場合は処理終了。
        DeleteSTAndFindNextWCheck = False
        Exit Function
    End If
    
    If lngMode = 0 Then                                         'lngModeが0(シート)の場合
        If Not IsActiveWorkSheet(ActiveSheet.Type) Then              'ActiveSheetがワークシートでない場合処理終了。
            DeleteSTAndFindNextWCheck = False
            Exit Function
        End If
    End If
    
    If ExistsProtectWorksheet(lngMode, True) Then         '保護シートがある場合処理終了。
        DeleteSTAndFindNextWCheck = False
        Exit Function
    End If
    
    If DeleteStrikethrough(ActiveCell) Then         'ActiveCellの取り消し線を削除する。存在しない場合、エラー表示する。
        lngNumOfResult = 1
    Else                                            '存在しない場合､エラー表示する｡
        MsgBox (ERR_MSG_03)
        DeleteSTAndFindNextWCheck = False
        Exit Function
    End If
    
    Call FindNextStrikethroughCell(lngMode)
    
    DeleteSTAndFindNextWCheck = True
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "DeleteSTAndFindNextWCheck")
    Call G_clsErr.ShowErrMsg
End Function

'-----取り消し線検索関連Function-----

'対象のセルに取り消し線がある場合、削除する。その後、次の取り消し線を検索し、存在すればそのセルへカーサーを移動する。
'
'@lngMode Long シート単位(0)かブック単位(1)かを設定する。
'@return Boolean 正常に削除終了する場合True、そうでない場合False。
Public Function FindNextStrikethroughCellWCheck(lngMode As Long) As Boolean
    
    Set G_clsErr = CreateErrClass(PROJ_NAME, VER)   'エラークラス(Cls_Error)のインスタンス生成
    
    If Not ExistsWorkbookWorksheet(ActiveWorkbook) Then         'ワークブックとワークシートの有無を確認。ない場合は処理終了。
        FindNextStrikethroughCellWCheck = False
        Exit Function
    End If
    
    If lngMode = 0 Then                                         'lngModeが0(シート)の場合
        If Not IsActiveWorkSheet(ActiveSheet.Type) Then              'ActiveSheetがワークシートでない場合処理終了。
            FindNextStrikethroughCellWCheck = False
            Exit Function
        End If
    End If
    
    Call ProtectUserInterfaceOnly                   '保護されているシートについて、マクロで動作するように設定を変更。
    
    If Not FindNextStrikethroughCell(lngMode) Then  '取り消し線の次のセルを検索し、存在しない場合は処理終了。
        MsgBox (ERR_MSG_03)
        FindNextStrikethroughCellWCheck = False
        Exit Function
    End If
    
    FindNextStrikethroughCellWCheck = True
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "FindNextStrikethroughCellWCheck")
    Call G_clsErr.ShowErrMsg
End Function

'ワークシートやワークブックの現在のActiveCellの次にある取り消し線の文字を探して、そのセルを選択する。
'ワークブックの検索の順番は、以下の通り。
'現在のシートのActiveCell以降にあるセル、当該シートの最初からActiveCellまでのセル、次のシートのA1セル。
'次のシートもセルと同様に最初のシートに戻って検索する。
'
'@lngMode Long シート単位(0)かブック単位(1)かを設定する。
'@return Boolean 存在する場合True、存在しない場合False。
Public Function FindNextStrikethroughCell(lngMode As Long) As Boolean
    Dim bResult As Boolean
    
    On Error GoTo AnyErr
    
    Select Case lngMode
        Case 0  'シートの場合
            bResult = FindNextStrikethroughCellWSheetLoop
        Case 1  'ブックの場合
            bResult = FindNextStrikethroughCellWAllSheetsLoop
    End Select
    
    FindNextStrikethroughCell = bResult
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "FindNextStrikethroughCell")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'ワークシートの現在のActiveCellの次にある取り消し線の文字を探して、そのセルを選択する。
'ワークシートの検索の順番は、以下の通り。
'現在のシートのActiveCell以降にあるセル、当該シートの最初からActiveCellまでのセル。
'
'@return Boolean 存在する場合True、存在しない場合False。
Private Function FindNextStrikethroughCellWSheetLoop() As Boolean
    On Error GoTo AnyErr
    
    If Not DividedFindNeeded Then   '1stHalfと2ndHalfで分割して検索が不要な場合
        FindNextStrikethroughCellWSheetLoop = FindNextStrikethroughCellWOtherSheet(ActiveSheet)     'UsedRangeの範囲を検索。
    Else                        '1stHalfと2ndHalfで分割して検索が必要な場合
        FindNextStrikethroughCellWSheetLoop = FindNextStrikethroughCellWSheet2ndHalfLoop            'ActiveCellより後半を検索。
        If Not FindNextStrikethroughCellWSheetLoop Then
            FindNextStrikethroughCellWSheetLoop = FindNextStrikethroughCellWSheet1stHalfLoop        'ActiveCellより前半を検索。
        End If
    End If
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "FindNextStrikethroughCellWSheetLoop")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'TargetSheet内の取り消し線の文字を探して、そのセルを選択する。
'
'@TargetSheet Worksheet 検索対象のWorksheet。
'@return Boolean 存在する場合True、存在しない場合False。
Private Function FindNextStrikethroughCellWOtherSheet(TargetSheet As Worksheet) As Boolean
    Dim Cell1 As Range
    Dim TargetCells As Range
    
    On Error GoTo AnyErr
    Set TargetCells = TargetSheet.UsedRange
    
    For Each Cell1 In TargetCells
        If IsStrikethrough(Cell1) Then
            TargetSheet.Select
            Cell1.Select
            FindNextStrikethroughCellWOtherSheet = True
            Exit Function
        End If
    Next
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "FindNextStrikethroughCellWOtherSheet")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'ワークシートの現在のActiveCellより前に存在する次にある取り消し線の文字を探して、そのセルを選択する。
'UsedRangeの範囲をもとに、最初のセルからActiveCellまでを検索し、選択する。
'
'@return Boolean 存在する場合True、存在しない場合False。
Private Function FindNextStrikethroughCellWSheet1stHalfLoop() As Boolean
    Dim TargetCells As Range
    Dim Cell1 As Range
    Dim StartCell As Range
    Dim lngLastCol As Long

    On Error GoTo AnyErr
    
    'UsedRangeの範囲をベースに、最初のセルからActiveCellのある行の最後のセルまでを設定。
    With ActiveSheet.UsedRange
        lngLastCol = .Columns(.Columns.Count).Column
    End With
    Set TargetCells = ActiveSheet.UsedRange
    Set StartCell = TargetCells(1)  'UsedRangeの最初のセル
'    Set TargetCells = ActiveSheet.Range(StartCell, ActiveSheet.Cells(ActiveCell.Row, ActiveCell.SpecialCells(xlLastCell).Column))
    Set TargetCells = ActiveSheet.Range(StartCell, ActiveSheet.Cells(ActiveCell.Row, lngLastCol))
    
    For Each Cell1 In TargetCells
        If Cell1.Row < ActiveCell.Row Then          'ActiveCellの行よりも前のセルの場合
            If IsStrikethrough(Cell1) Then
                Cell1.Select
                FindNextStrikethroughCellWSheet1stHalfLoop = True
                Exit Function
            End If
        ElseIf Cell1.Row = ActiveCell.Row Then      'ActiveCellの行と同じ場合
            If Cell1.Column < ActiveCell.Column Then    'ActiveCellの列より小さい場合
                If IsStrikethrough(Cell1) Then
                    Cell1.Select
                    FindNextStrikethroughCellWSheet1stHalfLoop = True
                    Exit Function
                End If
            Else
                Exit Function
            End If
        End If
    Next
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "FindNextStrikethroughCellWSheet1stHalfLoop")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'ワークシートの現在のActiveCellより後に存在する次にある取り消し線の文字を探して、そのセルを選択する。
'UsedRangeの範囲をもとに、現在のセルからActiveCell意向を検索し、選択する。
'
'@return Boolean 存在する場合True、存在しない場合False。
Private Function FindNextStrikethroughCellWSheet2ndHalfLoop() As Boolean
    Dim TargetCells As Range
    Dim Cell1 As Range
    Dim StartCell As Range
    Dim lngLastRow As Long, lngLastCol As Long

    On Error GoTo AnyErr
    
    With ActiveSheet.UsedRange
        lngLastRow = .Rows(.Rows.Count).Row
        lngLastCol = .Columns(.Columns.Count).Column
    End With
    'UsedRangeの範囲をベースに、ActiveCellのある行からそれ以降にあるセルを設定。
'    Set TargetCells = ActiveSheet.Range(ActiveSheet.Cells(ActiveCell.Row, ActiveSheet.UsedRange.Column), ActiveCell.SpecialCells(xlLastCell))
    Set TargetCells = ActiveSheet.Range(ActiveSheet.Cells(ActiveCell.Row, ActiveSheet.UsedRange.Column), ActiveSheet.Cells(lngLastRow, lngLastCol))
    
    For Each Cell1 In TargetCells
        If Cell1.Row = ActiveCell.Row Then
            If Cell1.Column > ActiveCell.Column Then
                If IsStrikethrough(Cell1) Then
                    Cell1.Select
                    FindNextStrikethroughCellWSheet2ndHalfLoop = True
                    Exit Function
                End If
            End If
        Else
            If IsStrikethrough(Cell1) Then
                Cell1.Select
                FindNextStrikethroughCellWSheet2ndHalfLoop = True
                Exit Function
            End If
        End If
    Next
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "FindNextStrikethroughCellWSheet2ndHalfLoop")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'ActiveCellと使用済みセルの行を比較し、検索対象がUsedRangeを分割して検索する必要があるかないかを応答する。
'ActiveCellのRowとColumnとUsedRangeのRowとColumnを使って判断する。
'UsedRangeの最初のセルと最後のセルについては、分割して検索する必要があると判断する。
'
'@return Boolean 検索対象がUsedRangeを分割して検索する必要が場合True、そうでない場合False。
Private Function DividedFindNeeded() As Boolean
    Dim lngLastRow As Long, lngLastCol As Long
    
    On Error GoTo AnyErr
    
    If ActiveCell.Row < ActiveSheet.UsedRange.Row Then      'ActiveCellの行が使用済みセルの先頭より前の場合
        DividedFindNeeded = False
    ElseIf ActiveCell.Row = ActiveSheet.UsedRange.Row Then  'ActiveCellの行が使用済みセルの先頭と同じ場合
        If ActiveCell.Column < ActiveSheet.UsedRange.Column Then     'ActiveCellの列が使用済みセルより前の場合
            DividedFindNeeded = False
        Else
            DividedFindNeeded = True
        End If
    Else                                                    'ActiveCellの行が使用済みセルの先頭より後の場合
        With ActiveSheet.UsedRange
            lngLastRow = .Rows(.Rows.Count).Row
            lngLastCol = .Columns(.Columns.Count).Column
        End With
        
'        If ActiveCell.Row < ActiveCell.SpecialCells(xlLastCell).Row Then        'ActiveCellの行が使用済みの最終セルより前の場合
        If ActiveCell.Row < lngLastRow Then        'ActiveCellの行が使用済みの最終セルより前の場合
        
            DividedFindNeeded = True
'        ElseIf ActiveCell.Row = ActiveCell.SpecialCells(xlLastCell).Row Then    'ActiveCellの行が使用済みの最終セルと同じ場合
        ElseIf ActiveCell.Row = lngLastRow Then    'ActiveCellの行が使用済みの最終セルと同じ場合
'            If ActiveCell.Column > ActiveCell.SpecialCells(xlLastCell).Column Then 'ActiveCellの列が使用済みセルの最終セル以上の場合
            If ActiveCell.Column > lngLastCol Then 'ActiveCellの列が使用済みセルの最終セル以上の場合
                DividedFindNeeded = False
            Else
                DividedFindNeeded = True
            End If
        Else                                                                'ActiveCellの行が使用済みの最終セルより後の場合
            DividedFindNeeded = False
        End If
    End If
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "DividedFindNeeded")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'ワークブックの現在のワークシートの現在のActiveCellの次にある取り消し線の文字を探して、そのセルを選択する。
'ワークブックの検索の順番は、以下の通り。
'現在のシートのActiveCell以降にあるセル、当該シートの最初からActiveCellまでのセル、次のシートのA1セルから検索。
'シートの最後まで検索したら、最初のシートに戻って検索する。
'
'@return Boolean 存在する場合True、存在しない場合False。
Private Function FindNextStrikethroughCellWAllSheetsLoop() As Boolean
    Dim Result As Boolean
    Dim SheetNo As Long, TargetSheetNo As Long
    Dim TargetSheet As Worksheet
    
    On Error GoTo AnyErr
    
    If Not DividedFindNeeded Then   '最初のWorksheetについて1stHalfと2ndHalfで分割して検索が不要な場合
        FindNextStrikethroughCellWAllSheetsLoop = FindNextStrikethroughCellWOtherSheet(ActiveSheet)     'UsedRangeの範囲を検索。
    Else                        '最初のWorksheetについて2ndHalfだけを検索する場合
        FindNextStrikethroughCellWAllSheetsLoop = FindNextStrikethroughCellWSheet2ndHalfLoop            'ActiveCellより後半を検索。
    End If
        
    If FindNextStrikethroughCellWAllSheetsLoop Then     '見つかった場合処理終了。
        Exit Function
    Else                                                '見つからなかった場合
        For SheetNo = 0 To ActiveWorkbook.Worksheets.Count - 2  'シートの検索は、ActiveSheetを除くため、-1ではなく-2にする。
            TargetSheetNo = (ActiveSheet.Index + SheetNo) Mod ActiveWorkbook.Worksheets.Count + 1
            Set TargetSheet = ActiveWorkbook.Worksheets(TargetSheetNo)
            If TargetSheet.Visible Then 'シートが非表示の場合は次のシートへ移動。
                FindNextStrikethroughCellWAllSheetsLoop = FindNextStrikethroughCellWOtherSheet(TargetSheet)
                If FindNextStrikethroughCellWAllSheetsLoop Then Exit Function
            Else        '非表示シートはスキップ。
                MsgBox (ERR_MSG_05)
            End If
        Next
    End If
    
    FindNextStrikethroughCellWAllSheetsLoop = FindNextStrikethroughCellWSheet1stHalfLoop                'ActiveSheetの前半を検索。
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "FindNextStrikethroughCellWAllSheetsLoop")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'-----その他Function-----
'ワークシートWsの使用中のセルの数を応答する。
'
'@Ws Worksheet 対象のワークシート。
'@return Long 使用中のセルの数。
Private Function CalcMaxNum(Ws As Worksheet) As Long
    On Error GoTo AnyErr
    
    CalcMaxNum = Ws.UsedRange.Count
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "CalcMaxNum")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'ワークブックWbの使用中のセルの数を応答する。
'
'@Wb Workbook 対象のワークブック。
'@return Long 使用中のセルの数。
Private Function CalcMaxNumAllSheets(Wb As Workbook) As Long
    Dim wsSheet As Worksheet
    Dim MaxNum As Long
    
    On Error GoTo AnyErr
    
    For Each wsSheet In Wb.Worksheets
        MaxNum = MaxNum + wsSheet.UsedRange.Count
    Next
    
    CalcMaxNumAllSheets = MaxNum
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "CalcMaxNumAllSheets")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'ProgressBarを使用して、シート単位、もしくはブック単位で指定の関数を実施する。
'
'@lngMode Long シート単位(0)かブック単位(1)かを設定する。
'@strFuncName 実行する関数名。
'@params() Variant 実行する関数の引数。中身は、p(0)は検索対象のワークシート、もしくはワークブック。p(1)はそれ以外の引数。
'@lngMaxNum Long ループ処理の回数。
Private Function PBarInitialize(lngMode As Long, strFuncName As String, params() As Variant, Optional olngMaxNum As Long = -1)
    Dim lngMaxNum As Long
    Dim strActualFuncName As String
    Dim vParams() As Variant
        
    On Error GoTo AnyErr
    
    ReDim G_cellArray(0)
    vParams = params
    
    '最大値の取得、実行関数の設定
    Select Case lngMode
        Case 0  'シートの場合
            If olngMaxNum = -1 Then
                lngMaxNum = CalcMaxNum(ActiveSheet)
            Else
                lngMaxNum = olngMaxNum
            End If
            strActualFuncName = strFuncName & "WSheetLoop"
            Set vParams(0) = ActiveSheet
        Case 1  'ブックの場合
            If olngMaxNum = -1 Then
                lngMaxNum = CalcMaxNumAllSheets(ActiveWorkbook)
            Else
                lngMaxNum = olngMaxNum
            End If
            strActualFuncName = strFuncName & "WAllSheetsLoop"
            Set vParams(0) = ActiveWorkbook
    End Select
    
    Set G_PBar = New Cls_ProgressBar
    G_PBar.Caption = strFuncName
    G_PBar.Count = lngMaxNum
    G_PBar.FuncName = strActualFuncName
    G_PBar.Args = vParams
    
    G_PBar.CloseFlag = True
    G_PBar.ValidStop = True
    
    G_PBar.Show
    
    PBarInitialize = True
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("Find", "PBarInitialize")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'Cell1のセル情報をG_cellInfoに追加する。
'
'@Cell1 Range 対象のセル
Private Sub AddCellInfo(Cell1 As Range)
    Dim lngNum As Long

    On Error GoTo AnyErr
        lngNum = UBound(G_cellArray) + 1
        ReDim Preserve G_cellArray(lngNum)
        Set G_cellArray(lngNum) = Cell1
    
    Exit Sub
AnyErr:
    Call G_clsErr.SetError("Find", "AddCellInfo")
    Call Err.Raise(Err.Number, , Err.Description)
End Sub

Global variable

G_PBarはProgressBarのための変数です。
G_cellArrayは、検索した結果をいれる配列です。
G_lngNumOfResultは、取り消し線を削除た数をいれるLong値です。

Function

M_ShowFindForm

FindFormを表示するだけです。

FindFontColorWCheck

背景色せんたくがめんｗ尾表示して、色を選択した後、その色をFontのColorとしてワークブックやワークシート内を検索します。
lngModeは、FindFormのComboBoxからの値で、ワークシート検索なのかワークブック検索なのかを設定します。

ソース中身は色々あります。
ExistsWorkbookWorksheetは、ワークブックとワークシートの有無を確認します。
これは、検索をしようとしたときに対象のワークブックがないとエラーとなるためそれを止めます。
ワークシートがない場合も同様です。例えばグラフシートしかないような場合を想定します。
IsActiveWorkSheetは、現在のシートがワークシートかを確認します。シート検索の場合、ワークシートない場合は処理を終了します。
ここまでが事前のCheckに対する処理です。

ProtectUserInterfaceOnlyは、ワークシートが保護されている場合、マクロでは使えるようにするための処理です。

CreateColorPatternsClassは背景色選択画面クラスの初期化です。
その後SelectBgColorで画面を表示し、色を取得します。
取得後はクラスを解放して、バックグラウンドで開いているワークブックを閉じます。

FindFontColorWPBarは、ProgressBarを使いつつ、文字色検索をおこないます。
結果がない場合、ないことを通知します。

FindFontColorWPBar

ProgressBarで文字色を検索する処理を実施します。ProgressBarの使い方は、Excel VBA 第6回 ProgressBarの作成で示していますが、少し厄介です。
PBarInitializeで処理は実行されます。
その結果は_cellArrayに保存されるため、その結果に応じて、結果の最初セルを選択します。
そのセルが非表示シートにある場合は次のセルを選択します。
また、G_cellArrayは、CellArrayにも設定され、呼び出し元に返されます。

FindFontColorWSheetLoop

ワークシート内の文字色検索のループ処理です。
UsedRangeを使用して使用しているセルだけを検索します。IsFontColorを実行することでセルに指定の文字色(lngColor)があるかを確認し、存在する場合AddCellInfoで、G_cellArrayにそのセルを追加します。
G_PBar.Valueは、セルを検索するたびインクリメントし、ProgressBarを更新します。

FindFontColorWAllSheetsLoop

ワークブック内の文字色検索のループ処理です。
ワークシートごとにFindFontColorWSheetLoopを呼び出しているだけです。

IsFontColor

Cell1にlngColorの文字色が存在するかを確認します。
IsNullでCell1のFont.Colorを調べ、Nullの場合は文字(Characters)ごとにFont.Colorが設定されるため、一文字ずつ確認します。
Nullでない場合はセルで共通の値が設定されるため、その値を確認します。

FindStrikethroughWCheck

ここからは取り消し線の検索処理です。内容は文字色検索とほぼ同じです。
違うのは、FindStrikethroughPBarで取り消し線の進捗バーを使うだけです。ですので、関数はまとめようと思えば可能です。

FindStrikethroughPBar

内容は文字色検索とほぼ同じですので割愛します。

FindStrikethroughWSheetLoop

内容は文字色検索とほぼ同じですので割愛します。

FindStrikethroughWAllSheetsLoop

内容は文字色検索とほぼ同じですので割愛します。

IsStrikethrough

内容は文字色検索とほぼ同じですので割愛します。

DeleteStrikethroughWCheck

取り消し線を削除する処理です。この関数では、あらかじめCellArrayに取り消し線を含むセルの配列があって、それを削除する実装にしています。
上のほうで記載した通り、取り消し線を検索する処理に時間がかかるため、事前に検索済みの場合は改めて検索しないつくりにしました。
ExistsWorkbookWorksheetやIsActiveWorkSheetは文字色検索や取り消し線検索と同じですが、その後が少し違います。
ExistsProtectWorksheetでは、保護シートがあるかどうかを検索し、存在する場合は処理を終了にしました。
二つ理由があります。
・保護シートがあるのに取り消し線を削除するのはインターフェイスとして問題かなと思いました。削除するのであれば保護シートをユーザー自身が解除してからのほうがよい。
・保護シートの選択などを許容するために、ProtectUserInterfaceOnlyを作ってマクロから保護シートを処理できるように試したのですが、どうしても取り消し線を削除してからシート選択をしようとすると保護シートは選択できないというエラーが発生する。
二つ目の理由があって、ユーザーに削除してよいか問い合わせたうえで削除という実装もしませんでした。
でもいまだになぜ選択できないのか不明です。

また、lngNumOfResultの取り方が検索と違います。
検索の場合はUBound(CellArray)で取得していましたが、ここでは削除した数が必要となるため、DeleteStrikethroughPBarの引数に、lngNumOfResultを入れて出力としました。

DeleteStrikethroughPBar

lngNumOfResultだけ検索と違う処理です。「DeleteStrikethroughWCheck」で記載した理由です。

DeleteStrikethroughWSheetLoop

内容は文字色検索とほぼ同じですので割愛します。

DeleteStrikethroughWAllSheetsLoop

内容は文字色検索とほぼ同じですので割愛します。

DeleteStrikethrough

内容は文字色検索とほぼ同じですので割愛します。

FindDeleteStrikethroughWCheck～FindDeleteStrikethrough

ここからは、取り消し線の検索と削除用の関数です。やっていることはほとんど同じです。

DeleteSTAndFindNextWCheck～DeleteSTAndFindNextWCheck

ここからは、現在のセルの取り消し線を削除して、次に取り消し線のあるセルを選択する処理です。やっていることはほとんど同じです。

FindNextStrikethroughCellWCheck～FindNextStrikethroughCell

ここからは、次の取り消し線を検索して、そのセルを選択する処理です。やっていることはほとんど同じです。

FindNextStrikethroughCellWSheetLoop

次の取り消し線を検索してそのセルを選択する処理のシート内の検索処理です。FindNextStrikethroughCellの関数から呼ばれる関数です。
この関数では、UsedRangeとActiveCellをみながら、次の取り消し線のセルを検索します。
シート内の次の取り消し線のあるセルの検索の順番は、以下のとおりです。
ActiveCellから後方に取り消し線があるかを検索し、そこで見つかればそのセルを選択します（図の青字）。
最後のセルまで検索して見つからない場合、先頭のセルからActiveClelまで検索します（図の赤字）。

FindNextStrikethroughCellWSheet2ndHalfLoop、FindNextStrikethroughCellWSheet1stdHalfLoopという関数で、後半と前半の検索をする仕組みとしました。
なお、これ以外にFindNextStrikethroughCellWOtherSheetがあり、これはセル全体を分割せず検索する場合に使用します。

ActiveCellは、UsedRange上にあるとはかぎりません。
下図の通り、UsedRangeとActiveCellの関係は存在しえます。
ActiveCellがAからDまでは、UsedRangeの最初から最後まで検索します。
ActiveCellがE、Iは、UsedRangeの当該セル以外を検索します。
ActiveCellがFからHまでは、UsedRangeをActiveCellで分割して後半⇒前半の順に検索します。
ActiveCellがJからMまでは、UsedRangeの最初から最後まで検索します。
これを識別する関数が、DividedFindNeededであり、分割する必要があるかを確認します。
なお、EやIは、分割必要と判断します。

FindNextStrikethroughCellWOtherSheet

TargetSheetのUsedRangeを最初から順に取り消し線を検索します。
本関数は、ワークブック検索でも使用します。

FindNextStrikethroughCellWSheet1stHalfLoop

ActiveCellより前半を検索する関数です。
コメントアウトされている部分はもともと記載していた箇所でしたが、ワークシートが保護されている場合動作しなかったため、すぐ下の記載に書き換えました。
Excel仕様によると、保護シートではSpecialCellsを使えないようです。

TargetCellsは、UsedRangeの範囲から、ActiveCellを含む前半のセルの範囲を設定しています。
その後、このTargetCellsの範囲でActiveCellの行と列をみながら検索箇所を絞り込んでいます。
ActiveCellの行より前のセルは、TargetCellsの該当行を最初の列から最後の列まで検索します。
ActiveCellの行と同じセルは、TargetCellsの該当行の最初の列からActiveCellの列の前まで検索します。
その間に取り消し線のあるセルがあれば選択します。

FindNextStrikethroughCellWSheet2ndHalfLoop

ActiveCellより後半を検索する関数です。
コメントアウトされている部分は、FindNextStrikethroughCellWSheet1stHalfLoopと同じ理由です。

TargetCellsは、UsedRangeの範囲から、ActiveCellを含む後半のセルの範囲を設定しています。
ActiveCellの行と同じセルは、TargetCellsの該当行のActiveCellの列の後から最後の列まで検索します。
ActiveCellの行より後のセルは、TargetCellsの該当行の最初の列から最後の列まで検索します。
その間に取り消し線のあるセルがあれば選択します。

DividedFindNeeded

これは、FindNextStrikethroughCellWSheetLoopで内容を説明しましたので、割愛します。

FindNextStrikethroughCellWAllSheetsLoop

ワークブック単位で次の取り消し線を検索し、そのセルを選択します。
検索順は、ワークシートの拡張版です。ActiveCellのあるシートの後半を検索した後、次のワークシートへ飛び、最後のワークシートまで検索したら、先頭のワークシートから検索し、最後に最初のActiveCellのあるシートの前半を検索します。
なお、ワークシート遷移にあたり、非表示シートがある場合は、そのワークシートはスキップし、非表示があることを通知します。

CalcMaxNum

これは、ProgressBarにおいて対象セル数をカウントするため、ワークシートのUsedRangeのセルの数をカウントします。
ワークシート検索用です。

CalcMaxNumAllSheets

これもProgressBarの対象セル数をカウントしますが、ワークブック版です。

PBarInitialize

ProgressBarの初期化用の関数です。
Excel VBA 第6回 ProgressBarの作成で説明していますので割愛します。

AddCellInfo

検索で見つかったセルをG_cellArrayに追加します。
G_cellArray(0)はダミーで配列の1番からセルが入ります。

Workbookの妥当性の確認

本機能を実行するにあたり、ワークブックの有無やワークシートの有無を確認するためのモジュールを作成します。

WorkbookValidation.bas

Option Explicit

'-----Function-----

'ワークブックを開いている場合、ワークシートがあるか確認し、存在する場合、何もしない。
'ワークブックを開いていない場合、それを通知してマクロを終了する。
'ワークシートがない場合（グラフシートだけの場合を想定）、それを通知してマクロを終了する。
'
'@wbWorkbook Workbook 対象のワークブック。
'@return Boolean ワークブックがあって、ワークシートがある場合、True、そうでない場合False。
Public Function ExistsWorkbookWorksheet(Wb As Workbook) As Boolean
    On Error GoTo AnyErr
    
    If Wb Is Nothing Then
        MsgBox (ERR_MSG_01)
        Exit Function
    End If
        
    If Wb.Worksheets.Count = 0 Then
        MsgBox (ERR_MSG_02)
        Exit Function
    End If

    ExistsWorkbookWorksheet = True
    Exit Function
AnyErr:
    Call G_clsErr.SetError("WorkbookValidation", "ExistsWorkbookWorksheet")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'ActiveSheetがワークシートか確認する。
'ワークシートの場合、何もしない。ワークシートでない場合（グラフシートなど）、それを通知してマクロを終了する。
'
'@SheetType XlSheetType 対象のシートの型。
'@return Boolean ActiveSheetがワークシートの場合True、そうでない場合False。
Public Function IsActiveWorkSheet(SheetType As XlSheetType) As Boolean
    
    On Error GoTo AnyErr
    
    If SheetType = xlWorksheet Then
       IsActiveWorkSheet = True
    Else
        MsgBox (ERR_MSG_02)
        IsActiveWorkSheet = False
    End If

    Exit Function
AnyErr:
    Call G_clsErr.SetError("WorkbookValidation", "IsActiveWorkSheet")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'ワークブック内に保護シートがあるか確認する。
'
'@lngMode Long シート単位(0)かブック単位(1)かを設定する。
'@bNeedMsg Boolean 保護シートがある場合にメッセージを表示するかどうかを設定する。必要な場合True、そうでない場合False。
'@return Boolean 保護シートがある場合True、そうでない場合False。
Public Function ExistsProtectWorksheet(lngMode As Long, bNeedMsg As Boolean) As Boolean
    Dim wsSheet As Worksheet
    
    On Error GoTo AnyErr
    
    Select Case lngMode
        Case 0  'シートの場合
            If ActiveSheet.ProtectContents Then
                If bNeedMsg Then MsgBox (ERR_MSG_04)
                ExistsProtectWorksheet = True
            End If
        Case 1  'ワークブックの場合
            For Each wsSheet In ActiveWorkbook.Worksheets
                If wsSheet.ProtectContents Then
                    If bNeedMsg Then MsgBox (ERR_MSG_04)
                    ExistsProtectWorksheet = True
                    Exit Function
                End If
            Next
    End Select

    Exit Function
AnyErr:
    Call G_clsErr.SetError("WorkbookValidation", "ExistsProtectWorksheet")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

'保護されたシートについて、マクロでは操作可能にする。
'
'@return Boolean 現時点では未使用。
Public Function ProtectUserInterfaceOnly() As Boolean
    Dim wsSheet As Worksheet
    
    On Error GoTo AnyErr
    
    For Each wsSheet In ActiveWorkbook.Worksheets
        If wsSheet.ProtectContents Then
            Call wsSheet.Protect(UserInterfaceOnly:=True)
        End If
    Next
    
    Exit Function
AnyErr:
    Call G_clsErr.SetError("WorkbookValidation", "ProtectUserInterfaceOnly")
    Call Err.Raise(Err.Number, , Err.Description)
End Function

ソースコードの説明です。

ExistsWorkbookWorksheet

ワークブック、およびワークシートが存在するか確認し、存在しない場合はエラーを表示します。

IsActiveWorkSheet

ActiveSheetがワークシートか確認し、そうでない場合はエラーを表示します。

ExistsProtectWorksheet

ワークブック内に保護シートがあるかを確認します。
保護シートがある場合取り消し線の削除をしないために作りました。

ProtectUserInterfaceOnly

ワークブック内に保護シートがある場合マクロでは実行できるように、UserInterfaceOnlyを付与します。
しかし、これは検索でのみ実施しており、取り消し線の削除時は使用していません。

おわりに

今回は、セル内に文字色の違う文字が混在するような状態で、文字色検索をする、もしくは取り消し線のあるセルを検索するマクロを作成しました。
思ったよりも長くなりました。

もともと、文字色で検索するというマクロは作成済みで使用もしていましたが、今回それに取り消し線を追加し、さらにProgressBarで進捗を表示するようにしました（ProgressBarはもともとは標準のものを使っていた）。
さらに検索順番もActiveCell起点で検索するなどもしました。
といったところで、ずいぶんと元のソースコードと変わってしまい、ずいぶん複雑になりました。
まだ作ってから実績もなく、デバッグも十分でないような気がしますが、載せてみました。動作がおかしかったら申し訳ありません。
少し使ってみて、エラーがでたり、おかしな挙動部分は直していこうと思います。

修正履歴

Ribbon.basのShowFindFormの名称をR_ShowFindFormに修正。
customUI.xml内のbuttion id="Find"のOnActionをShowFindFormからR_ShowFindFormに修正。
WorkbookValidation.basを作成し、Find.basにふくまれていたExistsWorkbookWorksheet、IsActiveWorkSheet、ExistsProtectWorksheet、ProtectUserInterfaceOnlyの４つの関数を移動。
IsActiveWorkSheet関数で、グラフシートの場合にえらーとなっていたため修正。
Find.basのIsActiveWorkSheetの呼び出しで、シート検索かどうかの確認を実施していなかったため、修正。