SpceialCellsを改造した

Excel VBA

Excel の VBA で 特定の種類のセルを参照する
Range.SpecialCells というメソッドがあるんですが、
引数で指定できるセルの種類が１つしか指定できません。


例えば、下記の感じで使用します。

'選択中セルで定数が入力されているセルを参照する
Selection.SpecialCells(xlCellTypeConstants)

'選択中セルで数式が入力されているセルを参照する
Selection.SpecialCells(xlCellTypeFormulas)


引数には定数、数式のほかに可視セル(xlCellTypeVisible)や
コメントのあるセル(xlCellTypeComments)なんかも指定できて、
しかも動作も軽量なので便利なのだけど、
参照するセルをもうちょっと柔軟に指定できるようになると、
さらに便利になるなぁと思って、改造というか新しい関数を作りました。

Set 参照セル = ESpecialCells(参照対象のセル, 参照するセルの種類, 参照するセルの値)

という書式で使います。該当セルがなければ Nothing が戻り値になります。


参照するセルの種類は、演算子とオペランドを使って、下記の感じで指定できます。

"c + f"　…　定数(xlCellTypeConstants)か数式(xlCellTypeFormulas)
"v * c"　…　可視セル(xlCellTypeVisible)かつ定数(xlCellTypeConstants)
カッコを使って
"cm * (v + f)"　…　定数か数式のセルで、コメント(xlCellTypeComments)のあるセル


演算子は「+」と「*」のみ。

「+」和集合(union)　　　"a + b" は a か b のどちらかに含まれるセル
「*」積集合(Intersect)　"a * b" は a と b の両方に含まれるセル


オペランドは c とか f とかで指定して下記の通り定義しています。

af = 表示形式が設定されているセル(xlCellTypeAllFormatConditions)
av = 条件の設定が含まれているセル(xlCellTypeAllValidation)
b  = 空のセル (xlCellTypeBlanks)
cm = コメントが含まれているセル(xlCellTypeComments)
c  = 定数が含まれているセル(xlCellTypeConstants)
f  = 数式が含まれているセル(xlCellTypeFormulas)
l  = 使われたセル範囲内の最後のセル(xlCellTypeLastCell)
sf = 同じ表示形式が設定されているセル(xlCellTypeSameFormatConditions)
sv = 同じ条件の設定が含まれているセル(xlCellTypeSameValidation)
v  = すべての可視セル(xlCellTypeVisible)


引き算ができるようになれば、もっといいんだけど、僕にはできませんでした。

Option Explicit

'使い方 例:選択中セルの定数か数式の可視セルを選択しなおす
Public Sub usage()

    Dim r As Range
    Set r = ESpecialCells(Selection, "v*(c+f)")
    
    If r Is Nothing Then
        MsgBox "nothing"
    Else
        r.Select
    End If
    
    Set r = Nothing

End Sub


Public Function ESpecialCells _
    (ByRef SourceRange As Range, ByVal CellTypesExpr As String, _
     Optional ByVal Value As XlSpecialCellsValue = _
                 xlTextValues + xlNumbers + xlLogical + xlErrors) As Range
    
    ReDim StackRange(0) As Variant
    
    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)
        If IsNumeric(e) Then
            Call stackPush(StackRange, mySpecialCells(SourceRange, e, Value))
        ElseIf e = "*" Then
            Call stackPush(StackRange, _
                    myIntersect(stackPop(StackRange), stackPop(StackRange)))
        ElseIf e = "+" Then
            Call stackPush(StackRange, _
                        myUnion(stackPop(StackRange), stackPop(StackRange)))
        End If
    Next
    
    If Not stackEmpty(StackRange) Then
        If TypeName(stackPeek(StackRange)) = TypeName(Cells) Then
            Set ESpecialCells = stackPop(StackRange)
        End If
    End If

End Function

Private Function mySpecialCells _
    (ByVal SourceRange As Range, ByVal CellType As XlCellType, _
                                ByVal Value As XlSpecialCellsValue) As Range
    
    Dim ReturnRange As Range
    
    Dim SavedRange As Range
    If SourceRange.Count = 1 Then
        Dim DummyCellsRowIndex As Long
        If SourceRange.Row = Cells.Rows.Count Then
            DummyCellsRowIndex = Cells.Rows.Count - 1
        Else
            DummyCellsRowIndex = SourceRange.Row + 1
        End If
        
        Set SavedRange = SourceRange
        Set SourceRange = Application.Union _
                    (SourceRange, SourceRange.Cells(DummyCellsRowIndex, 1))
    End If
    
    On Error Resume Next
        Set ReturnRange = SourceRange.SpecialCells(CellType, Value)
    On Error GoTo 0
    
    If Not (ReturnRange Is Nothing Or SavedRange Is Nothing) Then
        Set ReturnRange = Application.Intersect(ReturnRange, SavedRange)
    End If
    
    Set SavedRange = Nothing
    
    Set mySpecialCells = ReturnRange

End Function

Private Function myIntersect(ByRef r1 As Range, ByRef r2 As Range) As Range

    If r1 Is Nothing Or r2 Is Nothing Then
        Set myIntersect = Nothing
    Else
        Set myIntersect = Application.Intersect(r1, r2)
    End If

End Function

Private Function myUnion(ByRef r1 As Range, ByRef r2 As Range) As Range

    If r1 Is Nothing And r2 Is Nothing Then
        Set myUnion = Nothing
    ElseIf r1 Is Nothing Then
        Set myUnion = r2
    ElseIf r2 Is Nothing Then
        Set myUnion = r1
    Else
        Set myUnion = Application.Union(r1, r2)
    End If

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)
        If InStr(1, "+*() ", c) > 0 Then
            If Not Literal = "" Then buf = buf & " " & CxlCellType(Literal)
            If Not c = " " Then buf = buf & " " & c
            Literal = ""
        Else
            Literal = Literal & c
        End If
    Next
    
    splitFormula = Split(Trim(buf), " ")

End Function

Private Function CxlCellType(ByVal s As String) As XlCellType

    Select Case LCase(Trim(s))
        ' 表示形式が設定されているセル(-4172)
        Case "af": CxlCellType = xlCellTypeAllFormatConditions
        
        ' 条件の設定が含まれているセル(-4174)
        Case "av": CxlCellType = xlCellTypeAllValidation
        
        ' 空のセル ( 4)
        Case "b":  CxlCellType = xlCellTypeBlanks
        
        ' コメントが含まれているセル(-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
    
    CxlCellType = CxlCellType
    
End Function

'############################################################################
'## 中置記法から後置記法に変換
'############################################################################
Public Function infix2postfix(ByVal infix As Variant) As Variant

    ReDim postfix(0) As Variant
    Call postfixExpression(array2stack(infix), postfix)
    infix2postfix = postfix

End Function

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 = "*" 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 = "+" Then
            Call stackPop(infix)
            Call postfixTerm(infix, postfix)
            Call stackPush(postfix, c)
        Else
            Exit Do
        End If
    Loop

End Sub

'############################################################################
'## スタック操作用の関数
'############################################################################
Private 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

Private 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

Private 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

Private 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