SpecialCellsを改造した PART2

エクセルでセル同士の差集合が得られるようになったので、
前に作った SpecialCells の拡張版、 ESpecialCells も改造しなおした。

結構複雑な条件の指定も可能になって、なかなかイカシます。

2008/06/19 追記： 定数に o (UsedRange外のセル)を追加した。

ESpecialCells メソッド

Rangeオブジェクトを返すメソッドです。
特定範囲のうち、指定された条件を満たしている全てのセル(Rangeオブジェクト)を返します。


ESpecialCells(TargetRange, CellTypesExpr, [Option1], [Option2])


引数について
TargetRange   必ず指定します。対象となるセル範囲を指定します。

CellTypesExpr 必ず指定します。取得するセルの種類を数式の表記で指定します。

  
  使用できる定数は、次に示すいずれかです。
   w  対象セル全体 (Whole)
   c  定数が含まれるセル (Constants)
   f  数式が含まれるセル (Formulas)
   o  UsedRange外のセル (Outside)
   b  空のセル (Blanks)
   v  可視セル (Visible)
   cm コメントが含まれているセル (Comments)
   
   l  UsedRangeの最後のセル (LastCell)
   af 条件付き書式が設定されているセル (AllFormatConditions)
   av 入力規則が設定されているセル (AllValidation)
   sf 同じ条件付き書式が設定されているセル (SameFormatConditions)
   sv 同じ入力規則が設定されているセル (SameValidation)
   
   +  和集合 (Union)
   *  積集合 (Intersect)
   -  差集合 (Except)
   
   () 演算順位

   
Option1, Option2 は省略可能です。

  XlSpecialCellsValues クラスの定数を使用すると、
  引数 TypeExpression に c(定数) または f(数式) を設定したとき、
  特定の種類の定数や数式を含むセルだけを取得することができます。
  複数の値を加算して指定すると、複数の定数や数式を指定できます。
  この引数を省略すると、すべての定数および数式が対象になります。
  
  使用できる定数は、次に示す XlSpecialCellsValues クラスのいずれかです。
   xlErrors
   xlLogical
   xlNumbers
   xlTextValues
 
 Range を指定すると、
 引数 CellTypesExpr に sf(同じ条件付書式) や sv(同じ入力規則) を設定したときの、
 基準のセル(そのセルと同じ条件付書式や入力規則)となります。
 この引数を省略すると、ActiveCell が基準のセルとなります。
 
 
 
 使用例
 次の使用例はシート全体から定数か数式で数値のセルを選択します。
    ESpecialCells(Cells, "c+f", xlNumbers).Select
 
 
 次の使用例は選択範囲からコメントのないセルを選択します。
    ESpecialCells(Selection, "w-cm").Select
 
 
 次の使用例は選択範囲からRange("A1")と同じ入力規則の空のセルを選択します。
    ESpecialCells(Selection, "sv*b", Range("A1")).Select


 次の使用例は選択範囲からRange("A1")と同じ条件付き書式のテキストのセルを選択します。
 Option1 と Option2 の順番はどちらでも構いません
    ESpecialCells(Selection, "sf*c", Range("A1"), xlTextValues).Select
    ESpecialCells(Selection, "sf*c", xlTextValues, Range("A1")).Select
 
 
 次の使用例は選択範囲から空のセルに "hoge" を入力します。
 Selection.SpecialCells(xlBlanks) とは異なり UsedRange を超えた範囲も選択されます。
    ESpecialCells(Selection, "b+o").Value = "hoge"
 
 
 次の使用例は非表示の行を削除します。(非表示の列がある場合はエラーになります)
    ESpecialCells(Rows, "w-v").EntireRow.Delete

ソースコード

Option Explicit


Public Function ESpecialCells _
    (         ByRef TargetRange   As Range  , _
              ByVal CellTypesExpr As String , _
     Optional ByRef Opt1          As Variant, _
     Optional ByRef Opt2          As Variant  ) As Range
    
    '# オプション引数
    Dim SpecialCellsValue As Long
    Dim BaseCell          As Range
    
    ' Long型の場合 XlSpecialCellsValue クラスの値とする(Opt1を優先)
    If TypeName(Opt1) = "Long" Then
        SpecialCellsValue = CLng(Opt1)
    ElseIf TypeName(Opt2) = "Long" Then
        SpecialCellsValue = CLng(Opt2)
    End If
    
    ' 指定がない場合は、全ての種類とする
    If SpecialCellsValue = 0 Then
        SpecialCellsValue = xlTextValues + xlNumbers + xlLogical + xlErrors
    End If
    
    
    ' Range型の場合 sf, sv の時の基準セルとする(Opt1を優先)
    If TypeName(Opt1) = "Range" Then
        Set BaseCell = Opt1.Cells(1, 1)
    ElseIf TypeName(Opt2) = "Range" Then
        Set BaseCell = Opt2.Cells(1, 1)
    End If
    
    ' 指定がない場合は、アクティブセルを基準セルとする
    If BaseCell Is Nothing Then
        Set BaseCell = ActiveCell
    End If
    
    
    ' 演算用のスタック
    ReDim StackRange(0) As Variant
    
    ' CellTypesExpr を後置記法の配列に変換する
    Dim Postfix As Variant
    Postfix = Infix2Postfix(SplitFormula(CellTypesExpr))
    
    ' 後置記法の配列を処理する
    Dim i As Long
    For i = 0 To UBound(Postfix)
        
        Dim e As Variant
        e = Postfix(i)
        
        Dim CellType As Long
        CellType = CxlCellType(e)
        
        If Not CellType = 0 Then
        
            Call StackPush(StackRange, _
                mySpecialCells(TargetRange      , CellType, _
                               SpecialCellsValue, BaseCell  ))
        
        ElseIf e = "*" Then
        
            ' スタックから Range を２つ pop し 積集合を push する
            Call StackPush(StackRange, _
                    Intersect2(StackPop(StackRange), StackPop(StackRange)))
        
        ElseIf e = "+" Then
        
            ' スタックから Range を２つ pop し 和集合を push する
            Call StackPush(StackRange, _
                        Union2(StackPop(StackRange), StackPop(StackRange)))
        
        ElseIf e = "-" Then
        
            ' スタックから２つ Range を pop し 差集合を push する
            Dim r1 As Range, r2 As Range
            Set r1 = StackPop(StackRange)
            Set r2 = StackPop(StackRange)
            
            Call StackPush(StackRange, Except2(r2, r1))
        End If
        
    Next
    
    
    ' 戻り値が Range かチェックしてから返す
    If TypeName(StackPeek(StackRange)) = "Range" Then
        Set ESpecialCells = StackPop(StackRange)
    End If

End Function


' ESpecialCellsから呼ばれて SpecialCells を実行する
Private Function mySpecialCells _
    (ByVal TargetRange       As Range              , _
     ByVal CellType          As XlCellType         , _
     ByVal SpecialCellsValue As XlSpecialCellsValue, _
     ByRef BaseCell          As Range                ) As Range
    
    ' CellType に応じて処理する
    Select Case CellType
        
        ' 指定した範囲をそのまま返す
        Case xlWhole ' (これは XlCellType クラスではない)
            Set mySpecialCells = TargetRange
        
        ' UsedRange の外側
        Case xlOutside ' (これも XlCellType クラスではない)
            Set mySpecialCells = Except2(TargetRange, _
                                         TargetRange.Parent.UsedRange)
        
        ' 基準のセルがある場合
        Case xlCellTypeSameFormatConditions, xlCellTypeSameValidation
            On Error Resume Next
            Set mySpecialCells _
                = Intersect2(TargetRange, BaseCell.SpecialCells(CellType))
            On Error GoTo 0
        
        ' 基準のセルがない場合 (SpecialCellsValue の指定がある)
        Case xlCellTypeConstants, xlCellTypeFormulas
            On Error Resume Next
            Set mySpecialCells _
                = Intersect2(TargetRange, _
                      TargetRange.SpecialCells(CellType, SpecialCellsValue))
            On Error GoTo 0
            
        ' 基準のセルがない場合 (SpecialCellsValue の指定がない)
        Case Else
            On Error Resume Next
            Set mySpecialCells _
                = Intersect2(TargetRange, TargetRange.SpecialCells(CellType))
            On Error GoTo 0
    
    End Select

End Function


' CellTypesExpr で使用できる定数
Private Function CxlCellType(ByVal v As Variant) As XlCellType

    If Not TypeName(v) = "String" Then Exit Function
    
    Select Case LCase(Trim(v))
        ' 全てのセル(1)
        Case "w" : CxlCellType = xlWhole
        
        ' 条件付き書式が設定されているセル(-4172)
        Case "af": CxlCellType = xlCellTypeAllFormatConditions
        
        ' 入力規則が含まれているセル(-4174)
        Case "av": CxlCellType = xlCellTypeAllValidation
        
        ' 空のセル ( 4)
        Case "b" : CxlCellType = xlCellTypeBlanks
        
        ' UsedRangeの外側 ( 3)
        Case "o" : CxlCellType = xlOutside
        
        ' コメントが含まれているセル(-4144)
        Case "cm": CxlCellType = xlCellTypeComments
        
        ' 定数が含まれているセル( 2)
        Case "c" : CxlCellType = xlCellTypeConstants
        
        ' 数式が含まれているセル(-4132)
        Case "f" : CxlCellType = xlCellTypeFormulas
        
        ' 使われたセル範囲内の最後のセル( 11)
        Case "l" : CxlCellType = xlCellTypeLastCell
        
        ' 同じ条件付き書式が設定されているセル(-4173)
        Case "sf": CxlCellType = xlCellTypeSameFormatConditions
        
        ' 同じ入力規則が含まれているセル(-4175)
        Case "sv": CxlCellType = xlCellTypeSameValidation
        
        ' すべての可視セル( 12)
        Case "v" : CxlCellType = xlCellTypeVisible
        
        ' いずれでもない
        Case Else: CxlCellType = 0
        
    End Select
    
End Function


'############################################################################
'## 集合操作用の関数
'############################################################################

' 複数のセル ArgList の和集合(Range)を返す
Public Function Union2(ParamArray ArgList() As Variant) As Range

    Dim buf As Range
    
    Dim i As Long
    For i = 0 To UBound(ArgList)
        If TypeName(ArgList(i)) = "Range" Then
            If buf Is Nothing Then
                Set buf = ArgList(i)
            Else
                Set buf = Application.Union(buf, ArgList(i))
            End If
        End If
    Next
    
    Set Union2 = buf

End Function


' 複数のセル ArgList の積集合(Range)を返す
Public Function Intersect2(ParamArray ArgList() As Variant) As Range

    Dim buf As Range
    
    Dim i As Long
    For i = 0 To UBound(ArgList)
        If Not TypeName(ArgList(i)) = "Range" Then
            Exit Function
        ElseIf buf Is Nothing Then
            Set buf = ArgList(i)
        Else
            Set buf = Application.Intersect(buf, ArgList(i))
        End If
        
        If buf Is Nothing Then Exit Function
    Next
    
    Set Intersect2 = buf

End Function


' SourceRange から ArgList を差し引いた差集合(Range)を返す
Public Function Except2 _
    (ByRef SourceRange As Variant, ParamArray ArgList() As Variant) As Range

    If TypeName(SourceRange) = "Range" Then
        
        Dim buf As Range
        
        Set buf = SourceRange
        
        Dim i As Long
        For i = 0 To UBound(ArgList)
            If TypeName(ArgList(i)) = "Range" Then
                Set buf = Intersect2(buf, Invert2(ArgList(i)))
            End If
        Next
        
        Set Except2 = buf
        
    End If

End Function


' SourceRange の補集合(Range)を返す
Public Function Invert2(ByRef SourceRange As Variant) As Range

    If Not TypeName(SourceRange) = "Range" Then Exit Function
    
    Dim sh As Worksheet
    Set sh = SourceRange.Parent
    
    Dim buf As Range
    Set buf = SourceRange.Parent.Cells
        
    Dim a As Range
    For Each a In SourceRange.Areas
        
        Dim AreaTop    As Long
        Dim AreaBottom As Long
        Dim AreaLeft   As Long
        Dim AreaRight  As Long
        
        AreaTop = a.Row
        AreaBottom = AreaTop + a.Rows.Count - 1
        AreaLeft = a.Column
        AreaRight = AreaLeft + a.Columns.Count - 1
        
        
        '■□□
        '■×□  ×が Area~ の四隅の座標
        '■□□  抽出するのは■の部分
        Dim RangeLeft   As Range
        Set RangeLeft = GetRangeWithPosition(sh, _
            sh.Cells.Row, sh.Cells.Column, sh.Rows.Count, AreaLeft - 1)
        '   Top           Left             Bottom         Right
        
        '□□■
        '□×■  ×が Area~ の四隅の座標
        '□□■  抽出するのは■の部分
        Dim RangeRight  As Range
        Set RangeRight = GetRangeWithPosition(sh, _
            sh.Cells.Row, AreaRight + 1, sh.Rows.Count, sh.Columns.Count)
        '   Top           Left           Bottom         Right
        
        
        '□■□
        '□×□  ×が Area~ の四隅の座標
        '□□□  抽出するのは■の部分
        Dim RangeTop    As Range
        Set RangeTop = GetRangeWithPosition(sh, _
            sh.Cells.Row, AreaLeft, AreaTop - 1, AreaRight)
        '   Top           Left      Bottom       Right
        
        
        '□□□
        '□×□  ×が Area~ の四隅の座標
        '□■□  抽出するのは■の部分
        Dim RangeBottom As Range
        Set RangeBottom = GetRangeWithPosition(sh, _
            AreaBottom + 1, AreaLeft, sh.Rows.Count, AreaRight)
        '   Top              Left      Bottom         Right
        
        
        Set buf = Intersect2(buf, _
            Union2(RangeLeft, RangeRight, RangeTop, RangeBottom))
        
    Next
    
    Set Invert2 = buf

End Function


' 四隅を指定して Range を得る
Private Function GetRangeWithPosition( _
    ByRef sh     As Worksheet, _
    ByVal Top    As Long     , ByVal Left  As Long, _
    ByVal Bottom As Long     , ByVal Right As Long) As Range
    
    '# 無効条件
    If Top > Bottom Or Left > Right Then
        Exit Function
    ElseIf Top < 0 Or Left < 0 Then
        Exit Function
    ElseIf Bottom > Cells.Rows.Count Or Right > Cells.Columns.Count Then
        Exit Function
    End If
    
    Set GetRangeWithPosition _
        = sh.Range(sh.Cells(Top, Left), sh.Cells(Bottom, Right))

End Function


'############################################################################
'## 中置記法から後置記法に変換
'############################################################################

' 数式を各要素に分割した配列で返す
Public Function SplitFormula(ByVal Expression As String) As Variant

    Dim buf As String, Literal As String
    
    Dim i As Long
    For i = 1 To Len(Expression) + 1
        
        Dim c As String * 1
        c = Mid(Expression, i, 1)
        
        ' へんな書き方だが正規表現[-+*()\s]を使うよりは安いはず
        If InStr(1, "+-*() ", c) > 0 Then
            If Not Literal = "" Then
                buf = buf & " " & Literal
            End If
            
            If Not c = " " Then
                buf = buf & " " & c
            End If
            
            Literal = ""
        Else
            Literal = Literal & c
        End If
    Next
    
    ' 要素を空白で分割したのを Split で配列にする
    SplitFormula = Split(Trim(buf), " ")

End Function


' 中置記法の配列を後置記法の配列に変換
Public Function Infix2Postfix(ByVal Infix As Variant) As Variant

    ReDim Postfix(0) As Variant
    
    ' Array2Stack は pop を shift のように使うためのセコ技
    ' shift より pop のほうがコスト安い
    Call PostfixExpression(Array2Stack(Infix), Postfix)
    
    Infix2Postfix = Postfix

End Function


' PostficFactor, PostfixTerm, PostfixExpression は
' 奥村晴彦『C言語による最新アルゴリズム事典(ISBN4-87408-414-1)を参考にした
Private Sub PostfixFactor(ByRef Infix As Variant, ByRef Postfix As Variant)

    If Not Not StackEmpty(Infix) Then Exit Sub
    
    If StackPeek(Infix) = "(" Then
        Call StackPop(Infix)
        Call PostfixExpression(Infix, Postfix)
        If StackEmpty(Infix) Then
            If StackPeek(Infix) = ")" Then Call StackPop(Infix)
        End If
    Else
        Call StackPush(Postfix, StackPop(Infix))
    End If

End Sub

Private Sub PostfixTerm(ByRef Infix As Variant, ByRef Postfix As Variant)

    Call PostfixFactor(Infix, Postfix)
    
    Do While Not StackEmpty(Infix)
        Dim c As String * 1: c = StackPeek(Infix)
        If c = "*" Or c = "/" Then
            Call StackPop(Infix)
            Call PostfixFactor(Infix, Postfix)
            Call StackPush(Postfix, c)
        Else
            Exit Do
        End If
    Loop

End Sub

Private Sub PostfixExpression(ByRef Infix As Variant, ByRef Postfix As Variant)

    Call PostfixTerm(Infix, Postfix)
    
    Do While Not StackEmpty(Infix)
        Dim c As String * 1: c = StackPeek(Infix)
        If c = "+" Or c = "-" Then
            Call StackPop(Infix)
            Call PostfixTerm(Infix, Postfix)
            Call StackPush(Postfix, c)
        Else
            Exit Do
        End If
    Loop

End Sub

'############################################################################
'## スタック操作用の関数
'############################################################################

' スタックへプッシュする
Public Function StackPush _
    (ByRef ArrayItems As Variant, ByVal PushedItem As Variant)

    ReDim Preserve ArrayItems(UBound(ArrayItems) + 1) As Variant
    
    If IsObject(PushedItem) Then
        Set ArrayItems(UBound(ArrayItems)) = PushedItem
    Else
        ArrayItems(UBound(ArrayItems)) = PushedItem
    End If

End Function


' スタックからポップする
Public Function StackPop(ByRef ArrayItems As Variant) As Variant

    If Not StackEmpty(ArrayItems) Then
        If IsObject(ArrayItems(UBound(ArrayItems))) Then
            Set StackPop = ArrayItems(UBound(ArrayItems))
        Else
            StackPop = ArrayItems(UBound(ArrayItems))
        End If
        ReDim Preserve ArrayItems(UBound(ArrayItems) - 1)
    End If
    
End Function


' スタックの頂上を得る
Public Function StackPeek(ByRef ArrayItems As Variant) As Variant

    If Not StackEmpty(ArrayItems) Then
        If IsObject(ArrayItems(UBound(ArrayItems))) Then
            Set StackPeek = ArrayItems(UBound(ArrayItems))
        Else
            StackPeek = ArrayItems(UBound(ArrayItems))
        End If
    End If

End Function


' スタックは空か？
Public Function StackEmpty(ByRef ArrayItems As Variant) As Boolean

    StackEmpty = (UBound(ArrayItems) = 0)

End Function


' 配列をスタックに変換
Public Function Array2Stack(ByRef ArrayItems As Variant) As Variant

    ReDim ReturnValue(UBound(ArrayItems) + 1) As Variant
    
    Dim i As Long
    For i = 0 To UBound(ArrayItems)
        ReturnValue(i + 1) = ArrayItems(UBound(ArrayItems) - i)
    Next
    
    Array2Stack = ReturnValue

End Function