備忘録２

' H列（氏名）が重複している場合、以下の優先度に従って行を抽出し、
' 別シートのコピーする
' 条件１：AJ列の値が高い行を優先
' 条件２：AJ列が同じ値であった場合はAK列の高い行を優先
' 条件３：AJ列・AK列ともに同じ値であった場合は上の行を優先
Sub 集計()
'シート名を取得
Dim tmpSheet As Worksheet
Set tmpSheet = Worksheets(Sheets(1).Name)

'作成対象のシートが存在すれば削除しておく
Dim tmpSheet2 As Worksheet
For Each tmpSheet2 In Worksheets
If tmpSheet2.Name = Sheets(1).Name & "結果" Then
Application.DisplayAlerts = False
tmpSheet2.Delete
Application.DisplayAlerts = True
End If
Next tmpSheet2

Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Sheets(1).Name & "結果"
Set tmpSheet2 = Worksheets(ActiveSheet.Name)

'ヘッダー行をコピー
tmpSheet.Rows(1).Copy
tmpSheet2.Rows(1).PasteSpecial

'一意の氏名リストを格納する
Dim nameList As New Collection

'氏名を一意になるようにnameListに取得
On Error Resume Next
For i = 1 To 200
nameList.Add tmpSheet.Cells(i + 1, 8).Value, tmpSheet.Cells(i + 1, 8).Value
Next
On Error GoTo 0

'コピー先のシートの行を保持
Dim cnt As Integer
cnt = 1

'１行目から２００行目まで、値を取得してコピーする
'ただし同じ氏名の行がある場合は条件に従って比較し、優先度の高い行をコピーする
For i = 1 To nameList.Count
'元シートを検索
Dim nameCnt As Integer
nameCnt = WorksheetFunction.CountIf(tmpSheet.Range("H2:H201"), nameList(i))

'元シートに値がある場合のみ実行
If nameCnt > 0 Then
'元シートに値が複数ある場合
If nameCnt > 1 Then

Dim foundCell As Range
Dim firstCell As Range
Dim targetRow As Integer
Dim valFirstAJ As String
Dim valFirstAK As String

'最初に検索されたセルの行の、AJ列とAK列の値を取得
Set firstCell = tmpSheet.Range("H2:H201").Find(what:=nameList(i))
valFirstAJ = tmpSheet.Cells(firstCell.Row, 36).Value
valFirstAK = tmpSheet.Cells(firstCell.Row, 37).Value

'2つめ以降に検索されたセルの行の、AJ列をAK列の値を取得。その後、比較して優先度の最も高い行をコピー
For j = 0 To nameCnt
Set foundCell = tmpSheet.Range("H2:H201").FindNext(firstCell)
valFoundAJ = tmpSheet.Cells(foundCell.Row, 36).Value
valFoundAK = tmpSheet.Cells(foundCell.Row, 37).Value

'AJ列とAK列の値を比較して、どの行を採用するか決定する
If valFirstAJ > valFoundAJ Then
targetRow = firstCell.Row
ElseIf valFirstAJ < valFoundAJ Then
targetRow = foundCell.Row
ElseIf valFirstAJ = valFoundAJ Then
If valFirstAK > valFoundAK Then
targetRow = firstCell.Row
ElseIf valFirstAK < valFoundAK Then
targetRow = foundCell.Row
ElseIf valFirstAK = valFoundAK Then
targetRow = firstCell.Row
End If
End If
Next

tmpSheet.Rows(targetRow).Copy
tmpSheet2.Rows(cnt + 1).PasteSpecial
cnt = cnt + 1
Else
'元シートに値が一つのみの場合はそのままコピーする
tmpSheet.Rows(i + 1).Copy
tmpSheet2.Rows(cnt + 1).PasteSpecial
cnt = cnt + 1

End If

End If


Next

End Sub