| |
返事を待っていましたが、こちらも平日は時間が余り採れないし、
あきらめて、一例を書きます。
検証を十分にしていないので、そちらでよく検討してください。
なお、人に依頼するのであれば、
テストデータ（サンプルデータ）くらい提示してください。
また、ExcelのVersionも示す必要があります。
Sub test()
Dim dic As Object
Dim k As Long
Dim r As Range
Dim myRange As Range
Dim myRange2 As Range
Dim myRange3 As Range
Dim e As Variant
Dim kaisu As Long
Dim c As Long
'現在のアクティブシートを作業対象とする（指定したほうがベターかも）
'ブロックの数を取得
kaisu = (Cells(1, Columns.Count).End(xlToLeft).Column + 1) \ 7
Set dic = CreateObject("Scripting.Dictionary")
For k = 1 To kaisu
c = 7 * (k - 1) + 1
dic.RemoveAll
'(1)重複を除いた日付を取得
For Each r In Range(Cells(2, c), Cells(Rows.Count, c).End(xlUp))
dic(r.Value) = Empty
Next
'(2)日付（昇順）得点（降順）でソート
Call mySort(c)
'(3)各日付単位に、Rank.EQ関数を使って順位を付ける
Set myRange = Cells(1, c).CurrentRegion '見出しを含む表
Set myRange2 = Intersect(myRange, myRange.Offset(1)) '見出し除く部分
For Each e In dic.keys
myRange.AutoFilter Field:=1, Operator:=xlFilterValues _
, Criteria2:=Array(2, e) '日付で抽出
Set myRange3 = myRange2.Columns(5).SpecialCells(xlCellTypeVisible)
'順位をつける（ワークシート関数Rank.EQを使う(同一順位を考慮））
For Each r In myRange2.Columns(6).SpecialCells(xlCellTypeVisible)
r.Value = Application.Rank_Eq(r.Offset(, -1), myRange3, 0)
Next
myRange.AutoFilter
Next
'(4)3位以内だけをSheet2に転記
myRange.AutoFilter Field:=6, Criteria1:="<=3", Operator:=xlAnd
myRange.Copy
Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(2).PasteSpecial
myRange.AutoFilter
Next
End Sub
Function mySort(k As Long) '列目から始まるブロックに関してソート
With ActiveSheet.Sort
.SortFields.Clear
'日付の昇順
.SortFields.Add Key:=Cells(2, k) _
, SortOn:=xlSortOnValues, Order:=xlAscending _
, DataOption:=xlSortNormal
'得点の降順
.SortFields.Add Key:=Cells(2, k + 4) _
, SortOn:=xlSortOnValues, Order:=xlDescending _
, DataOption:=xlSortNormal
.SetRange Cells(1, k).CurrentRegion
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
