ラブびあ

ビール。ときどきラブ

取消線の入ったセルを検索する

ExcelVBA

標準のFindNextでは検索できない「取消線の入ったセル」を検索するためのクラスです。「」の部分は簡単にカスタマイズできるので、簡単に任意の条件で検索する機能を作ることができます。

CellFinder

アクティブセルから「前へ」「次へ」を検索するクラスです。FindNext/FindBackに渡すICellFinderクラスで検索条件を判定します。

Option Explicit

'セル位置判定Enum
Private Enum vbCompareAddress
    vbBeforeCell
    vbActiveCell
    vbAfterCell
End Enum

'検索範囲決定
Private Function FindRange() As Range
    If Selection.CountLarge = 1 Or Selection.MergeCells Then
        Set FindRange = ActiveSheet.UsedRange
    Else
        Set FindRange = UsedRangeInSelection
    End If
    
    ' このFunctionはNothingを返さない
    If FindRange Is Nothing Then
        Set FindRange = ActiveCell
    End If
End Function

Public Function UsedRangeInSelection() As Range
    Set UsedRangeInSelection = Intersect(ActiveSheet.UsedRange, Selection)
End Function

'セル位置判定
Private Function CompareAddress(c As Range) As vbCompareAddress
    If ActiveCell.Address = c.Address Then
        CompareAddress = vbActiveCell
    Else
        CompareAddress = IIf(ActiveCell.Row < c.Row Or (ActiveCell.Row = c.Row And ActiveCell.Column < c.Column), vbAfterCell, vbBeforeCell)
    End If
End Function

'順方向検索
Public Sub FindNext(finder As ICellFinder)
    Call FindNext_(finder, vbAfterCell)
    Call FindNext_(finder, vbBeforeCell)
    Call Find(finder, ActiveCell, vbActiveCell)
    finder.NotFound
End Sub

Private Sub FindNext_(finder As ICellFinder, ca As vbCompareAddress)
    With FindRange
        Dim i As Long
        For i = 1 To .CountLarge
            Call Find(finder, .Cells(i), ca)
        Next
    End With
End Sub

'逆方向検索
Public Sub FindBack(finder As ICellFinder)
    Call FindBack_(finder, vbBeforeCell)
    Call FindBack_(finder, vbAfterCell)
    Call Find(finder, ActiveCell, vbActiveCell)
    finder.NotFound
End Sub

Private Sub FindBack_(finder As ICellFinder, ca As vbCompareAddress)
    With FindRange
        Dim i As Long
        For i = .CountLarge To 1 Step -1
            Call Find(finder, .Cells(i), ca)
        Next
    End With
End Sub

'検索判定
Private Sub Find(finder As ICellFinder, c As Range, ca As vbCompareAddress)
    If ca = CompareAddress(c) Then
        If finder.Find(c) Then
            c.Activate
            End
        End If
    End If
End Sub

ICellFinder

検索判定処理のインターフェースクラスです。FindでTrueを返すと検索にヒットしたことになります。

Option Explicit

'検索判定処理
Public Function Find(c As Range) As Boolean
End Function

'見つからなかった場合の処理
Public Sub NotFound()
End Sub

StrikethroughFinder

（ありがちな）取消線書式が設定されたセルを判定するクラスです。Findの引数cがチェック対象のセルで、取消線書式が付いていたらTrueを、なければFalseを返します。

Option Explicit
Implements ICellFinder

'検索判定処理
Public Function ICellFinder_Find(c As Range) As Boolean
    'セル単位
    If Not IsNull(c.Font.Strikethrough) Then
        ICellFinder_Find = c.Font.Strikethrough
        Exit Function
    End If
    
    '文字単位
    Dim i As Long
    For i = 1 To Len(c.Value)
        If c.Characters(Start:=i, Length:=1).Font.Strikethrough Then
            ICellFinder_Find = True
            Exit Function
        End If
    Next

    ICellFinder_Find = False
End Function

'見つからなかった場合の処理
Public Sub ICellFinder_NotFound()
    MsgBox "取消線は見つかりませんでした"
End Sub

使い方

標準モジュールでショートカットキーを割り当てます。このサンプルでは、F3キーで「次へ」Shift+F3キーで「前へ」取消線書式を含むセルを検索しています。つまりCellFinderをベースとして、ICellFinderを実装したクラスを用意するだけで、好みの検索機能を追加できるようになります！

Private finder As New CellFinder
Private ifinder As New StrikethroughFinder

Sub Auto_Open()
    Application.OnKey "{F3}", "FindNext"
    Application.OnKey "+{F3}", "FindBack"
End Sub

Sub FindNext()
    finder.FindNext ifinder
End Sub

Sub FindBack()
    finder.FindBack ifinder
End Sub

最後に

もう3年も前の投稿とのことですが、これを読んで、いまさらながら触発されまして、過去に作った機能をリファクタリングしてみて、この日記をつけました。投稿した方、ありがとうございました！
qiita.com