https://www.limecode.jp/entry/fungo/062-user-defined-function-zlookup

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：独自のZLOOKUP関数を作成

#VBA100本ノック 62本目
VLOOKUPは条件合致の先頭が取得されます。
この取得順番を指定できる関数を作成します。
ZLOOKUP(検索値,範囲,列番号,順番)
順番→0:先頭,-1:最後,>=1:その順番
※当該順がない場合は空白""を返す
※検索値がない場合は#N/Aを返す
※完全一致のみ対応、検索値は単一セル値限定

関数仕様
テスト結果

◇ 出題ページはこちら

ソースコード

メインモジュール

Option Explicit

' 100本ノック062：独自のZLOOKUP関数を作成
Function ZLOOKUP(ByVal 検索値 As Variant, 範囲 As Range _
    , ByVal 列番号 As Long, 順番 As Long) As Variant

    ' 列番号の引数チェック
    Dim 範囲列数 As Long: 範囲列数 = 範囲.Columns.Count
    Select Case 列番号
    Case 0:                  ZLOOKUP = CVErr(xlErrValue): Exit Function
    Case Is < -1:          ZLOOKUP = CVErr(xlErrValue): Exit Function
    Case Is > 範囲列数: ZLOOKUP = CVErr(xlErrRef): Exit Function
    End Select

    ' 範囲内の列番号をシート上の列番号に変換
    列番号 = 列番号 + 範囲.Column - 1

    ' 初期値として#N/Aをセット
    ZLOOKUP = CVErr(xlErrNA)
    
    ' 検索範囲の初期値をセット(範囲内の第1列 ∩ UsedRange)
    Dim ws検索対象 As Worksheet: Set ws検索対象 = 範囲.Worksheet
    Dim 検索範囲 As Range: Set 検索範囲 = Intersect(範囲, ws検索対象.UsedRange)
    
    If 検索範囲 Is Nothing Then Exit Function
    Set 検索範囲 = 検索範囲.Columns(1)
    
    ' Match関数による検索を繰り返す
    Dim R_発見行 As Long
    Dim R_前回の発見行 As Long
    Dim Count発見数 As Long: Count発見数 = 0
    Do
    
        R_発見行 = Match行番号(検索値, 検索範囲)
        
        ' 検索値なし
        If R_発見行 = 0 Then
            
            ' 順番が-1のときは前回の値を返してExit
            If 順番 = -1 And R_前回の発見行 > 0 Then
            
                ZLOOKUP = ws検索対象.Cells(R_前回の発見行, 列番号)
                Exit Function
            
            ' それ以外はExit(1つは見つかっていたらNAを""に上書き)
            Else
                If Count発見数 >= 1 Then ZLOOKUP = ""
                Exit Function
            End If
        
        ' 検索値あり
        Else
            
            Count発見数 = Count発見数 + 1
            
            ' 指定した順番に到達したら結果を返してExit
            If Count発見数 = 順番 Or 順番 = 0 Then
                ZLOOKUP = ws検索対象.Cells(R_発見行, 列番号)
                Exit Function
            End If
            
        End If
        
        ' 前回の発見を記録
        R_前回の発見行 = R_発見行
        
        ' 検索範囲を発見行以下に狭めて次のループへ
        Set 検索範囲 = Intersect(検索範囲, ws検索対象.Rows(R_発見行 + 1).Resize(検索範囲.Rows.Count))

    Loop

End Function

汎用関数モジュール

Option Explicit

' WorksheetFunctionの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-worksheetfunction
Function Fx() As WorksheetFunction
    Set Fx = WorksheetFunction
End Function

' 行番号の検索
' ◆ ブログ未掲載
Function Match行番号(ByVal 検索値 As Variant, 検索エリア As Range) As Long
    On Error Resume Next
    If IsDate(検索値) Then
        Dim x: x = CDbl(検索値)
        If Err.Number = 0 Then
            Match行番号 = Fx.Match(CDbl(検索値), 検索エリア, 0) + 検索エリア.Row - 1
            Exit Function
        End If
    End If

    Match行番号 = Fx.Match(検索値, 検索エリア, 0) + 検索エリア.Row - 1

End Function