はじめに
今回は、Excelの検索関連のマクロ作成です。
Excelの検索には書式検索があり、文字色や取り消し線など、色々な書式で検索することができます。
しかし、この場合少し制限があり、セル自体がひとつの書式になっている必要性があると思います（たぶん）。
そうなってくると意外と不便で、セル内の一部の文字色だけ違ったり、取り消し線があったりする場合、検索できません。
今回はそれを検索できるようにするマクロをつくります。
色々やっていたら複雑になってしまいました。
今回実施する内容
以下のような検索機能を作成する。Excelの検索フォームに似た感じで作成します。
・指定の文字色で検索
・取り消し線で検索
・取り消し線を削除
本機能は、リボン上にマクロを実装しアドイン化します（第2回参照）。
・リボン
・文字色、もしくは、取り消し線で検索
・文字色選択画面
・取り消し線を削除
ソースコード(Git Hub)
今回作成、編集したソースコードは以下です。
もともとの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の検索とほぼ同等で、シート、セルのアドレス、および、値を表示します。
また、検索ボックスはサイズ変更できるように実装しました。
フォームのソースコードは、以下です。
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
FormResize
Excel VBA 第5回 Win32APIの取り込みと64bit対応とフォームのサイズ変更で説明済みですので割愛します。
UserForm_Activate
Excel VBA 第5回 Win32APIの取り込みと64bit対応とフォームのサイズ変更で説明済みですので割愛します。
UserForm_Resize
Excel VBA 第5回 Win32APIの取り込みと64bit対応とフォームのサイズ変更で説明済みですので割愛します。
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)を使うことにしました。
背景色選択画面は、もともと背景色を選択するものであるため、ユーザーが誤解する可能性があること、「塗りつぶしの効果」を設定可能なため、色だけを選択しない可能性もあることといった点で、完璧ではなく、ユーザーの理解を必要とする実装ですが、文字色選択画面よりはオプションが少ないのでいいのかなとは思います。
この背景色選択画面は、検索するワークブックではなく、別のワークブックを新たに開き、そこで表示をさせます。そのワークブックは背景色を取得した後（文字色を選択した後）削除します。
これは、検索するワークブックで実施すると、以下の課題があるためです。
・そのワークブックのカーサーのある場所のセルの背景色がかわってしまう。
・そのワークブックのカーサーの場所の背景色を変えた後をもとに戻す必要がある。
・そのワークブックを編集したことになり、その後ワークブックを閉じるとき保存するかを聞かれてしまう。
ソースコードは、以下です。
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の追加
一部の修正です。
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回 リボンとアドイン作成を参照。
ソースコードは、以下です。
<?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にもソースを追加しました。
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を追加しました。
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が検索処理のメインです。
ここは関数が多くなりましたが、文字色検索関連、取り消し線検索関連、取り消し線削除関連でそれぞれ関数を作りました。
同じ記載が多くなったため、もう少しまとめたほうが良かったかもしれませんが、現状は分かれています。
ソースコードは以下です。
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の妥当性の確認
本機能を実行するにあたり、ワークブックの有無やワークシートの有無を確認するためのモジュールを作成します。
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の呼び出しで、シート検索かどうかの確認を実施していなかったため、修正。