範囲内でのセルの相対位置を求める

セルの範囲内での相対位置を求める

特定のセルが、指定範囲内の上から何番目にあるのかを求める必要があったので作った。

「指定範囲」は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の値が、〝上から何番目かを表す値〟になっているはず。

使ってみる

まず、

f:id:akashi_keirin:20201018090205j:plain

こんなセル範囲を用意する。

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内のコードは後掲する。)

こいつを、

f:id:akashi_keirin:20201018090209j:plain

こんなふうに配置したコマンドボタンに登録して使う。

動作風景

f:id:akashi_keirin:20201018090213g:plain

こんな風に動作する。

おわりに

もしかして、セル範囲内の相対位置を返す組み込みの関数とかそういうのがあったりするんでしょうか?

標準モジュール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