範囲内でのセルの相対位置を求める
セルの範囲内での相対位置を求める
特定のセルが、指定範囲内の上から何番目にあるのかを求める必要があったので作った。
「指定範囲」は1列、「特定のセル」は1個限定。
セルの相対位置を返すFunction
とりあえず、指定範囲を上から順に当たっていって、対象のセルの位置を見つけたときの順番を表す数を返したらいいと思った。
リスト1 標準モジュールRangeUtil
Public Function getRelativePosition( _ ByVal TargetRange As Range, _ ByVal Target As Range) As Long '……(1)' Dim ret As Long ret = 0 'Guard clause' If TargetRange.Columns.Count > 1 Then GoTo Finalizer '……(2)' If Target.Count > 1 Then GoTo Finalizer Dim rng As Range Set rng = Application.Intersect(TargetRange, Target) If rng Is Nothing Then GoTo Finalizer 'Main process' Dim i As Long Dim addressStr As String For i = 1 To TargetRange.Rows.Count '……(3)' If TargetRange.Cells(i, 1).Address = Target.Address Then ret = i Exit For End If Next 'Return value' Finalizer: getRelativePosition = ret End Function
まず、(1)の
Public Function getRelativePosition( _ ByVal TargetRange As Range, _ ByVal Target As Range) As Long
で引数と返り値の設定。
引数TargetRange
でセル範囲を受け取り、引数Target
で位置を調べる対象のセルを受け取る。
ちなみに、引数名の記法はパスカル記法にした。組み込みの引数名とかぶらないように考えるのがめんどくさくなったから。
そのうち、メソッド名もパスカル記法に変える日が来ると思う。いまのところキャメル記法だけど。
(2)からの5行、
If TargetRange.Columns.Count > 1 Then GoTo Finalizer If Target.Count > 1 Then GoTo Finalizer Dim rng As Range Set rng = Application.Intersect(TargetRange, Target) If rng Is Nothing Then GoTo Finalizer
はガード節。
セル範囲が2列以上あるとき、位置を調べる対象セルが2個以上あるとき、セル範囲内に位置を調べる対象セルがないとき、にそれぞれ「0
」を返すようにした。
(3)からの6行、
For i = 1 To TargetRange.Rows.Count If TargetRange.Cells(i, 1).Address = Target.Address Then ret = i Exit For End If Next
が位置を調べる処理。
1
からセル範囲の行数分だけループして、セルのアドレスが一致した時点でループを抜ける。
その時点での変数i
の値が、〝上から何番目かを表す値〟になっているはず。
使ってみる
まず、
こんなセル範囲を用意する。
A1セル~A14セルまでの範囲に、「TargetRange
」という名前が付けてある。
こうしておいて、次のコードで実験してみる。
リスト2 標準モジュールModuleMain
Private Sub detectRelativePosition() Dim relPos As Long relPos = RangeUtil.getRelativePosition( _ TargetRange:=Sh01.Range("TargetRange"), _ Target:=Selection) If relPos < 1 Then Call Provoke.makeUserSick( _ Message:="選択箇所がおかしいわボケwww", _ MsgBoxIcon:=mbiCritical, _ Title:="残念www") Exit Sub End If Call Provoke.makeUserSick( _ Message:="お前が選んだセルは、範囲内の上から" & _ CStr(relPos) & "番目やwww。", _ MsgBoxIcon:=mbiInformation, _ Title:="選択セルの範囲内相対位置を調べた結果www") End Sub
選択しているセルが、「TargetRange」と名付けたセルの上から何番目にあるのかを、ちょっと腹の立つメッセージボックスで表示するというだけのプログラム。
ちなみに、コード中のProvoke
というのは標準モジュールの名前で、その中にmakeUserSick
というメソッドを書いている。(標準モジュールProvoke
内のコードは後掲する。)
こいつを、
こんなふうに配置したコマンドボタンに登録して使う。
動作風景
こんな風に動作する。
おわりに
もしかして、セル範囲内の相対位置を返す組み込みの関数とかそういうのがあったりするんでしょうか?
註
標準モジュールProvoke
Option Explicit Public Enum MsgBoxIcon mbiCritical = vbCritical mbiExclamation = vbExclamation mbiInformation = vbInformation mbiQuestion = vbQuestion End Enum '///ち~んw用' Private Const MAKE_USER_SICK_2013 As String = _ " _______" & vbCrLf & _ " / \" & vbCrLf & _ "/ /・\ /・\ \" & vbCrLf & _ "|  ̄ ̄  ̄ ̄ | ち~んw" & vbCrLf & _ "| (_人_) |" & vbCrLf & _ "| \ | |" & vbCrLf & _ "\ \_| /" Private Const MAKE_USER_SICK_2010 As String = _ " _______" & vbCrLf & _ " / \ " & vbCrLf & _ "/ /・\ /・\ \" & vbCrLf & _ "|  ̄ ̄  ̄ | ち~んw" & vbCrLf & _ "| (_人_) |" & vbCrLf & _ "| \ | |" & vbCrLf & _ "\ \_| /" '///ユーザーを煽るAAを表示する' Public Sub makeUserSick( _ Optional ByVal Message As String, _ Optional ByVal MsgBoxIcon As MsgBoxIcon, _ Optional ByVal Title As String) If Message = "" Then Message = "涙拭けよwww" Dim ver As String ver = Application.Version Dim str As String Select Case ver Case "14.0" str = MAKE_USER_SICK_2010 Case "15.0" str = MAKE_USER_SICK_2013 Case "16.0" str = MAKE_USER_SICK_2013 Case Else str = MAKE_USER_SICK_2010 End Select Call MsgBox(Prompt:=Message & vbCrLf & str, _ Buttons:=MsgBoxIcon, _ Title:=Title) End Sub