Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

4545 / 76807

←次へ　｜　前へ→


	【77884】Re:ソートとフィルタの繰り返し処理

γ - 16/1/17(日) 19:28 -


	引用なし

	パスワード

返事を待っていましたが、こちらも平日は時間が余り採れないし、
あきらめて、一例を書きます。
検証を十分にしていないので、そちらでよく検討してください。

なお、人に依頼するのであれば、
テストデータ（サンプルデータ）くらい提示してください。
また、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

0 hits

▼

【77877】ソートとフィルタの繰り返し処理 みか 16/1/16(土) 23:00