指定列の項目毎に、別の指定列について最大値を求める

先日、次のような課題を目にした。
例えば、昨日のなんちゃって個人情報にて。各都道府県の、最年長者を抽出した表を作成したい。
f:id:Infoment:20190917230856p:plain

挑戦してみた。
f:id:Infoment:20190917231027p:plain

今回の作戦は、こうだ。

指定範囲を一行ずつ、都道府県をキーにして辞書に登録する。
同じ都道府県の場合は年齢を比較し、登録済みの年齢よりも大きい場合、
行ごと更新する。
完成した辞書について、都道府県ごとに一行ずつ、シートに貼り付ける。

作成したコードが ↓ こちら。

Sub Sample()
    Dim 列_年齢 As Long
        列_年齢 = Rows(1).Find("年齢").Column
    Dim 列_都道府県 As Long
        列_都道府県 = Rows(1).Find("都道府県").Column
    
    Dim myRng As Range
    Set myRng = Range("A1").CurrentRegion
    Dim r As Range
    Dim Dict As Dictionary
    Set Dict = New Dictionary
    
    Dim 年齢 As Variant
    Dim 都道府県 As String
        
        For Each r In myRng.Rows
            年齢 = r.Cells(列_年齢).Value
            都道府県 = r.Cells(列_都道府県).Value
            If Dict.Exists(都道府県) = False Then
                Dict(都道府県) = r.Value
            Else
                If Dict(都道府県)(1, 列_年齢) < r.Cells(列_年齢) Then
                    Dict(都道府県) = r.Value
                End If
            End If
        Next
        
        Sheets.Add After:=ActiveSheet
        
    Dim myItem As Variant
    Dim i As Long: i = 1
        For Each myItem In Dict.Items
            Cells(i, 1).Resize(, UBound(myItem, 2)) = myItem
            i = i + 1
        Next
End Sub

結果は ↓ こちら。
f:id:Infoment:20190917232216p:plain

意図したとおり、抽出することが出来た。ついでに、先日来シリーズで取り組んだ配列の編集クラスモジュールに、この機能を一般化して盛り込んでみた。

' 第一指定列の項目ごとに、第二指定列の指定条件のみを残す。
Public Function FilteringArrayAtDesignatedCriteria(item_column As Long, _
                                                    filter_column As Long, _
                                                    Optional filter_type As Excel.XlConsolidationFunction = xlMax)
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    
    Dim myKey As Variant
    Dim FilterItem As Variant
    
        If filter_type <> xlMin And filter_type <> xlMax Then filter_type = xlMax
    
        For i = 1 To rMax
            myKey = source_array(i, item_column)
            FilterItem = source_array(i, filter_column)
            If Dict.Exists(myKey) = False Then
                Dict(myKey) = source_row_array(i)
            Else
                Select Case filter_type
                    Case xlMax
                        If Dict(myKey)(1, filter_column) < source_array(i, filter_column) Then
                            Dict(myKey) = source_row_array(i)
                        End If
                    Case xlMin
                        If Dict(myKey)(1, filter_column) > source_array(i, filter_column) Then
                            Dict(myKey) = source_row_array(i)
                        End If
                End Select
            End If
        Next
        
    ReDim TempArray(rMin To Dict.Count, cMin To cMax)
        i = 1
        For Each myKey In Dict.Keys
            For c = cMin To cMax
                TempArray(i, c) = Dict(myKey)(1, c)
            Next
            i = i + 1
        Next
        
        FilteringArrayAtDesignatedCriteria = TempArray
End Function

テストコードがこちら。例によって、クラスモジュールに委ねた分だけ、こちらはスッキリしている。

Sub sample_2()
    Dim arr() As Variant
        arr = Range("A1").CurrentRegion.Value
        
    Dim SQC As SeaquenceClass
    Set SQC = New SeaquenceClass
        arr = SQC.TargetArray(arr).FilteringArrayAtDesignatedCriteria(11, 8, xlMax)
        
        Sheets.Add
        SQC.TargetArray(arr).PasteArray Range("A1")
End Sub