EXCEL VBA LARGE関数で取得した列にある先頭行の値を取得したい

Question

EXCELで集計やまとめをするマクロを作っています。
不良項目と不良数を1位2位3位、とランキング形式でまとめたいです。

不良数の方はLARGE関数を使用して1～3位を簡単に取得できますが、
不良数を取得した先頭行にある不良項目が取得方法がわかりませんでした。

前の質問で頂いた参考を基に書いてみて期待に一番近しくなりましたが、数値が同じだった場合、項目名も同じになってしまいました。
数値が同じだった場合は、左側を優先にした順位にしたいです。
やり方がありましたら教えて頂けると幸いです。

やりたいこと

H1～M6に入っている項目名と数値を取得し、A2～F6にまとめる
1行ごとに1番～3番目に大きかった数値と、1番～3番目大きかった数値の項目名を取得し、
左側に代入する

↓期待結果

↓下記プログラムの実行結果

プログラム

Sub Huryo_Rank()
Dim i As Integer
Dim first As Integer
Dim second As Integer
Dim third As Integer
Dim k_row_first As Integer
Dim k_name_first As String
Dim k_row_second As Integer
Dim k_name_second As String
Dim k_row_third As Integer
Dim k_name_third As String

For i = 2 To Cells(Rows.Count, "H").End(xlUp).Row
    first = WorksheetFunction.Large(Range(Cells(i, 8), Cells(i, 13)), 1)
    Cells(i, 2).Value = first
    second = WorksheetFunction.Large(Range(Cells(i, 8), Cells(i, 13)), 2)
    Cells(i, 4).Value = second
    third = WorksheetFunction.Large(Range(Cells(i, 8), Cells(i, 13)), 3)
    Cells(i, 6).Value = third
    
    
    k_row_first = WorksheetFunction.Match(first, Range(Cells(i, 8), Cells(i, 13)), 0) + 7
    k_name_first = Cells(1, k_row_first).Value
    Cells(i, 1).Value = k_name_first
    
    k_row_second = WorksheetFunction.Match(second, Range(Cells(i, 8), Cells(i, 13)), 0) + 7
    k_name_second = Cells(1, k_row_second).Value
    Cells(i, 3).Value = k_name_second
    
    k_row_third = WorksheetFunction.Match(third, Range(Cells(i, 8), Cells(i, 13)), 0) + 7
    k_name_third = Cells(1, k_row_third).Value
    Cells(i, 5).Value = k_name_third
    
    Next i

End Sub

環境

Windows 10
EXCEL 2019

Answer 1

コードはいくつか他の方があげてくださっているので違ったアプローチを。
VBAを使わない方法です。

作業セルO2～T6
O2に数式を入れてT6までコピー

=IF(H2=0,"",RANK.EQ(H2,$H2:$M2)*100+COLUMN())

ワースト
項目名（A2に入れてコピー）
※2位、3位はSMALLの最後の,1)を変更してください。

=IFERROR(INDEX($H$1:$M$1,0,MATCH(SMALL($O2:$T2,1),$O2:$T2,0)),"")

個数（B2に入れてコピー）
※こちらも2位,3位はSMALLの中を変更してください

=IFERROR(INDEX($H2:$M2,,MATCH(SMALL($O2:$T2,1),$O2:$T2,0)),"")

---

ベストアンサー出てましたね。失礼しました。

Answer 2

hatenaさんの後で気が引けますがｗ
提示されているシート名を「ランキング」
あと、作業用のシートとして「ソート作業」を追加してやってみました。

Sub s_Test1()
    Const cnsColBgn = 8     'H
    Const cnsColEnd = 13    'M
    Const cnsRowBgn = 2
    
    Dim lngRnk As Long
    Dim lngRowRnk As Long
    Dim lngColRnk As Long
    Dim lngRowEnd As Long
    Dim wshRnk As Worksheet
    Dim wshSrt As Worksheet
    
    Set wshRnk = Worksheets("ランキング")
    Set wshSrt = Worksheets("ソート作業")
    
    lngRowEnd = wshRnk.Cells(Rows.Count, cnsColBgn).End(xlUp).Row
    For lngRowRnk = cnsRowBgn To lngRowEnd
    
        wshRnk.Range(wshRnk.Cells(1, cnsColBgn), wshRnk.Cells(1, cnsColEnd)).Copy wshSrt.Range("A1")
        wshRnk.Range(wshRnk.Cells(lngRowRnk, cnsColBgn), wshRnk.Cells(lngRowRnk, cnsColEnd)).Copy wshSrt.Range("A2")
        For lngColRnk = cnsColBgn To cnsColEnd
            wshSrt.Cells(3, lngColRnk - cnsColBgn + 1) = lngColRnk
        Next lngColRnk
        
        With wshSrt
            .Sort.SortFields.Add Key:=Range(.Cells(2, 1), .Cells(2, cnsColEnd - cnsColBgn + 1)), Order:=xlDescending
            .Sort.SortFields.Add Key:=Range(.Cells(3, 1), .Cells(3, cnsColEnd - cnsColBgn + 1)), Order:=xlAscending
            .Sort.SetRange Range(.Cells(1, 1), .Cells(3, cnsColEnd - cnsColBgn + 1))
            .Sort.Orientation = xlLeftToRight
            .Sort.Apply
        End With
        
        For lngRnk = 1 To 3
            wshRnk.Cells(lngRowRnk, lngRnk * 2 - 1).Value = wshSrt.Cells(1, lngRnk).Value
            wshRnk.Cells(lngRowRnk, lngRnk * 2).Value = wshSrt.Cells(2, lngRnk).Value
        Next lngRnk
            
    Next lngRowRnk

    Set wshSrt = Nothing
    Set wshRnk = Nothing

End Sub

Answer 3

とりあえず現状のコードから最小限の変更でするという方針で。

Option Explicit

Sub Huryo_Rank()
Dim i As Integer
Dim first As Integer
Dim second As Integer
Dim third As Integer
Dim k_row_first As Integer
Dim k_name_first As String
Dim k_row_second As Integer
Dim k_name_second As String
Dim k_row_third As Integer
Dim k_name_third As String
Dim leftCol As Long


For i = 2 To Cells(Rows.Count, "H").End(xlUp).Row
    first = WorksheetFunction.Large(Range(Cells(i, 8), Cells(i, 13)), 1)
    If first = 0 Then GoTo Continue
    Cells(i, 2).Value = first
    leftCol = 8
    k_row_first = WorksheetFunction.Match(first, Range(Cells(i, leftCol), Cells(i, 13)), 0) + leftCol - 1
    k_name_first = Cells(1, k_row_first).Value
    Cells(i, 1).Value = k_name_first
    
    
    second = WorksheetFunction.Large(Range(Cells(i, 8), Cells(i, 13)), 2)
    If second = 0 Then GoTo Continue
    Cells(i, 4).Value = second
    If first = second Then leftCol = k_row_first + 1 Else leftCol = 8
    k_row_second = WorksheetFunction.Match(second, Range(Cells(i, leftCol), Cells(i, 13)), 0) + leftCol - 1
    k_name_second = Cells(1, k_row_second).Value
    Cells(i, 3).Value = k_name_second
    
    
    third = WorksheetFunction.Large(Range(Cells(i, 8), Cells(i, 13)), 3)
    If third = 0 Then GoTo Continue
    Cells(i, 6).Value = third
    If second = third Then leftCol = k_row_second + 1 Else leftCol = 8
    k_row_third = WorksheetFunction.Match(third, Range(Cells(i, leftCol), Cells(i, 13)), 0) + leftCol - 1
    k_name_third = Cells(1, k_row_third).Value
    Cells(i, 5).Value = k_name_third

Continue:
    Next i

End Sub

前の順位の値と同じなら、検索範囲をそれよりに右に狭めるというロジックです。

Comments

[nuko3]

最小限の変更、わかりやすくてとても助かります...
期待通りに動きました。ありがとうございます！

Answer 4

(参考程度)

Sub Test_Sample_Miniature()

    Dim i As Integer
    Dim first As Integer
    Dim second As Integer
    Dim third As Integer
    Dim k_row_first As Integer
    Dim k_name_first As String
    Dim k_row_second As Integer
    Dim k_name_second As String
    Dim k_row_third As Integer
    Dim k_name_third As String
    
    For i = 2 To Cells(Rows.Count, "H").End(xlUp).Row
        
        first = WorksheetFunction.Large(Range(Cells(i, 8), Cells(i, 13)), 1)
        Cells(i, 2).Value = first
        second = WorksheetFunction.Large(Range(Cells(i, 8), Cells(i, 13)), 2)
        Cells(i, 4).Value = second
        third = WorksheetFunction.Large(Range(Cells(i, 8), Cells(i, 13)), 3)
        Cells(i, 6).Value = third
        
        Dim iX As Integer: Dim iY As Integer: Dim iZ As Integer
        Dim MyRange As Range
        Dim intHitCol() As Integer
        Dim iWork As Integer: Dim iWorkCol As Integer
        Dim blnNext As Boolean
        ReDim Preserve intHitCol(0): iZ = 0: intHitCol(iZ) = 0
        '(first～third繰返し)
        For iX = 1 To 3
            iWork = 0
            iWorkCol = 0
            '(行繰返し)
            For Each MyRange In Range(Cells(i, 8), Cells(i, 13))
                If iWorkCol = 0 Then
                    Select Case iX
                        Case 1: iWork = first: iWorkCol = 1
                        Case 2: iWork = second: iWorkCol = 3
                        Case 3: iWork = third: iWorkCol = 5
                    End Select
                End If
                If MyRange = iWork Then
                    '(書込み済み列チェック)
                    blnNext = False
                    For iY = 0 To UBound(intHitCol)
                        If MyRange.Column = intHitCol(iY) Then
                            blnNext = True
                        End If
                    Next
                    '(ターゲット列ヒット)
                    If blnNext = False Then
                        Cells(i, iWorkCol).Value = Cells(1, MyRange.Column).Value
                        iZ = iZ + 1: ReDim Preserve intHitCol(iZ)
                        intHitCol(iZ) = MyRange.Column
                        Exit For
                    End If
                End If
            Next
        Next
    Next i
End Sub