Excel VBA質問箱 IV

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

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


4473 / 76735 ←次へ | 前へ→

【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 質問[未読]
【77878】Re:ソートとフィルタの繰り返し処理 γ 16/1/16(土) 23:04 発言[未読]
【77884】Re:ソートとフィルタの繰り返し処理 γ 16/1/17(日) 19:28 発言[未読]
【77886】Re:ソートとフィルタの繰り返し処理 γ 16/1/17(日) 20:24 発言[未読]
【77887】Re:ソートとフィルタの繰り返し処理 γ 16/1/17(日) 20:39 発言[未読]
【77888】Re:ソートとフィルタの繰り返し処理 みか 16/1/18(月) 8:35 お礼[未読]
【77889】Re:ソートとフィルタの繰り返し処理 γ 16/1/18(月) 20:44 発言[未読]
【77885】Re:ソートとフィルタの繰り返し処理 β 16/1/17(日) 20:03 発言[未読]

4473 / 76735 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free