April 4, 2014

Excelのオブジェクトの中心にあるセルを求める

TopLeftCell、BottomRightCellはあるが、CenterCellはない

Excel VBAにはTopLeftCell、 BottomRightCellというプロパティがあり、それぞれ、オブジェクトの左上、右下にあるセルをRangeオブジェクトとして取得できます。
ところが、オブジェクトの真ん中にあるセルを求めるプロパティはないため、ユーザー定義関数を作成しました。


新しく作成するcenterCell関数の仕様 

TopLeftCellとBottomRightCellの仕様は以下のようになっています。

.TopLeftCell 指定したオブジェクトの左上隅の下に位置するセルを表す Range オブジェクトを取得します。値の取得のみ可能です。
.BottomRightCell オブジェクトの右下隅の下に位置するセルを表す Range オブジェクトを取得します。値の取得のみ可能です。
Shape.TopLeftCell プロパティ
http://msdn.microsoft.com/ja-jp/library/microsoft.office.interop.excel.shape.topleftcell%28v=office.11%29.aspx

Shape.BottomRightCell プロパティ
http://msdn.microsoft.com/ja-jp/library/microsoft.office.interop.excel.shape.bottomrightcell%28v=office.11%29.aspx
ここでは、コードに簡単に統合できるように、ユーザー定義関数としてcenterCellを作成することにします。引数に対象となるオブジェクトを渡し、オブジェクトの中心の下に位置するセルを表すRangeオブジェクトを返すようにします。

実際の処理では、Range(.TopLeftCell, .BottomRightCell)の範囲をスキャンし、対象となるオブジェクトの中心とセルの中心の距離が最小となるセルを返しています。

コード

Function centerCell(ByRef targetObject As Variant) As Range
    Dim targetRange As Range
    Dim minIndex As Integer, minDistance As Double
    Dim originY As Double, originX As Double, targetY As Double, targetX As Double
    
    With targetObject
        Set targetRange = Range(.TopLeftCell, .BottomRightCell)
        
        originY = .Top + .Height / 2
        originX = .Left + .Width / 2
    End With
    
    With targetRange
        minDistance = Sqr(.Height ^ 2 + .Width ^ 2)
        
        For i = 1 To .Cells.Count
            targetY = .Cells(i).Top + .Cells(i).Height / 2
            targetX = .Cells(i).Left + .Cells(i).Width / 2
            
            distance = Sqr((targetY - originY) ^ 2 + (targetX - originX) ^ 2)
            If distance < minDistance Then
                minIndex = i
                minDistance = distance
            End If
        Next
        
        Set centerCell = .Cells(minIndex)
    End With
End Function

No comments :

Post a Comment