『多い順＋日付の並び替え』（aki）

今晩は。よろしくお願いします。
以下のようなデータがあります。
 A列に都道府県(23個)、B列に市区町村(126個)、C列に通称(230)、D列に日付が入っています。
このデータを、多い順にABCとし、最後に日付順にしたいのですが
こんなことってできるのでしょうか？

	[A]	[B]	[C]	[D]
[1]	大分類	中分類	小分類	受付日
[2]	埼玉県	越谷市	佐伯	4/3
[3]	埼玉県	越谷市	小諸	4/2
[4]	埼玉県	越谷市	小諸	4/3
[5]	埼玉県	越谷市	小諸	4/3
[6]	埼玉県	越谷市	台地	4/2
[7]	埼玉県	越谷市	近田	4/1
[8]	埼玉県	朝霞市	馬路	4/1
[9]	埼玉県	朝霞市	馬路	4/2
[10]	埼玉県	朝霞市	馬路	4/2
[11]	埼玉県	朝霞市	馬路	4/3
[12]	埼玉県	朝霞市	馬路	4/3
[13]	東京都	江東区	南町	4/4
[14]	東京都	江東区	北町	4/2
[15]	東京都	豊島区	関町	4/1
[16]	東京都	豊島区	関町	4/1
[17]	東京都	豊島区	中町	4/2
[18]	東京都	豊島区	中町	4/1
[19]	東京都	豊島区	中町	4/3
[20]	東京都	豊島区	中町	4/1
[21]	東京都	豊島区	中町	4/2
[22]	東京都	豊島区	中町	4/2
[23]	東京都	葛飾区	緑町	4/3
[24]	東京都	足立区	本町	4/1
[25]	東京都	足立区	粟町	4/4
[26]	東京都	渋谷区	横町	4/3
[27]	東京都	渋谷区	横町	4/2
[28]	東京都	渋谷区	横町	4/3

 このような並び替えを実施したい。
作業列を使い、COUNTIF関数で並び替えたのですが
どうしても、D列がうまくいきません。

	[A]	[B]	[C]	[D]
[1]	大分類	中分類	小分類	受付日
[2]	東京都	豊島区	中町	4/1
[3]	東京都	豊島区	中町	4/1
[4]	東京都	豊島区	中町	4/2
[5]	東京都	豊島区	中町	4/2
[6]	東京都	豊島区	中町	4/2
[7]	東京都	豊島区	中町	4/3
[8]	東京都	豊島区	関町	4/1
[9]	東京都	豊島区	関町	4/1
[10]	東京都	渋谷区	横町	4/2
[11]	東京都	渋谷区	横町	4/3
[12]	東京都	渋谷区	横町	4/3
[13]	東京都	足立区	本町	4/1
[14]	東京都	足立区	粟町	4/4
[15]	東京都	江東区	北町	4/2
[16]	東京都	江東区	南町	4/4
[17]	東京都	葛飾区	緑町	4/3
[18]	埼玉県	越谷市	小諸	4/2
[19]	埼玉県	越谷市	小諸	4/3
[20]	埼玉県	越谷市	小諸	4/3
[21]	埼玉県	越谷市	近田	4/1
[22]	埼玉県	越谷市	台地	4/2
[23]	埼玉県	越谷市	佐伯	4/3
[24]	埼玉県	朝霞市	馬路	4/1
[25]	埼玉県	朝霞市	馬路	4/2
[26]	埼玉県	朝霞市	馬路	4/2
[27]	埼玉県	朝霞市	馬路	4/3
[28]	埼玉県	朝霞市	馬路	4/3

よろしくお願いします。
 環境は、Windows7、2007 です。
2016/04/06　0:25 (aki)



＜ 使用 Excel：Excel2007、使用 OS：Windows7 ＞
 
----
 Sub test()
    Dim sh1 As Worksheet, mx1 As Long, c As Range, rng As Range, col As Long
    Set sh1 = Sheets("Sheet1"): mx1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
    With sh1.Sort '並び替え（昇順）
        .SortFields.Clear
　　    .SortFields.Add Key:=Range("A2")
        .SortFields.Add Key:=Range("B2")
        .SortFields.Add Key:=Range("C2")
        .SortFields.Add Key:=Range("D2")
        .SetRange Range("A2:D" & mx1): .Header = xlNo: .Apply
    End With
    sh1.Columns("E:G").Insert '作業列挿入
    sh1.Columns("E:G").NumberFormatLocal = "G/標準"
    For Each c In sh1.Range("E2:G" & mx1)
        col = c.Offset(0, -4).Column
        Set rng = sh1.Range(sh1.Cells(2, col), sh1.Cells(mx1, col))
        c.Value = WorksheetFunction.CountIf(rng, c.Offset(0, -4).Value) 'カウント数書込み
    Next
    With sh1.Sort '並び替え（降順）
        .SortFields.Clear
        .SortFields.Add Key:=Range("E2"), Order:=xlDescending
        .SortFields.Add Key:=Range("F2"), Order:=xlDescending
        .SortFields.Add Key:=Range("G2"), Order:=xlDescending
        .SetRange Range("A2:G" & mx1): .Header = xlNo: .Apply
    End With
    sh1.Columns("E:G").Delete '作業列削除
 End Sub
（マリオ） 2016/04/06(水) 06:35

----
 >>このデータを、多い順にABCとし

 この意味がちょっとわかりづらいのですが、要は大分類、中分類、小分類　の組み合わせで多いもの順ということですよね？

 であれば、COUNTIFS で数は取得できますよね？　これを E列あたりに記述して、 E列降順、D列昇順で並び替えればよろしいのでは？

（β） 2016/04/06(水) 07:02
----
もう解決済みだと思いますが、あえて。

＞作業列を使い、COUNTIF関数で並び替えたのですが
＞どうしても、D列がうまくいきません。
ちょっとよくわからない。
D列の日付順のほうが、単純なソートキーの追加ですむ話のように見えます。

むしろ、C列だけでCOUNTIFをとっているとしたらそれは間違いにつながる懸念。
例えば中町なんて、いろいろな区にありませんか？
B列&C列くらいでCOUNTIFする必要があると思われます。

（γ） 2016/04/06(水) 07:17
----
おはようございます。
分類で同じ件数になる場合の順序がよく分からないですが、一応下記コードで例とは同じ並びになります。

 Sub test()
    Dim lRow As Long

    lRow = Range("A" & Rows.Count).End(xlUp).Row

    With Sheets("Sheet1").Sort
        .SortFields.Clear
        .SortFields.Add key:=Range("D2"), Order:=xlAscending
        .SetRange Range("A1:D" & lRow)
        .Header = xlYes
        .Apply
    End With

    Range("E:G").Insert
    Range("E2:E" & lRow).Formula = "=COUNTIF(A:A,A2)"
    Range("F2:F" & lRow).Formula = "=COUNTIF(B:B,B2)-INDEX(D:D,MATCH(B2,B:B,0))/100000"
    Range("G2:G" & lRow).Formula = "=COUNTIF(C:C,C2)"
    Range("E2:G" & lRow).Value = Range("E2:G" & lRow).Value

    With Sheets("Sheet1").Sort.SortFields
        .Clear
        .Add key:=Range("E2"), Order:=xlDescending
        .Add key:=Range("F2"), Order:=xlDescending
        .Add key:=Range("G2"), Order:=xlDescending
    End With
    With Sheets("Sheet1").Sort
        .SetRange Range("A1:G" & lRow)
        .Header = xlYes
        .Apply
    End With

    Range("E:G").Delete

 End Sub

（sy） 2016/04/06(水) 07:25
----
 あっ、Ａ列が異なる場合に、必ずＣ列も異なるわけじゃないからダメだ!
 【県】が異なっても、【中町】とかありますもんね。
（マリオ） 2016/04/06(水) 07:39
----
 「区」のある「市」は日本に、１９市あります。
 ******************************************************************
 北海道札幌市、宮城県仙台市、埼玉県さいたま市、千葉県千葉市
 神奈川県横浜市、神奈川県川崎市、神奈川県相模原市、新潟県新潟市
 静岡県静岡市、静岡県浜松市、愛知県名古屋市、京都府京都市
 大阪府大阪市、大阪府堺市、兵庫県神戸市、岡山県岡山市
 広島県広島市、福岡県北九州市、福岡県福岡市
 ******************************************************************
 
 ★コードを書く上では、関係ないのですが…。
 「区」のある「市」は、中分類のところに「市」と「区」をまとめて書き込むのでしょうか？
 西区が付く市は多いですから。
 名古屋市西区
 浜松市西区
 横浜市西区
 さいたまし西区
（マリオ） 2016/04/06(水) 07:53
----
 江東区と足立区が逆になってしまいますが

 E2セル =COUNTIF(A:A,A2)
 G2セルまでフィルコピーしたら下方向にフィルコピー

 並べ替えで「先頭行をデータの見出しとして使用する」にチェックを入れて

 最優先されるキー　　E列　　 降順
 次に優先されるキー　F列     降順
 次に優先されるキー　G列     降順
 次に優先されるキー　中分類　昇順
 次に優先されるキー　受付日　昇順

 でもこれだと多分他の地区でも並びが希望通りではなくなるかも。
（se_9） 2016/04/06(水) 08:09
----
すいません。
通勤途中なので簡単にしか書けないですが、

各分類で件数が違う場合は多い順
件数が同じ時は日付の若い順
と言う事でしょうか？

でしたらE列の式にもA列の判定でmatchを当てはめて下さい。

式の方考えたら始めのソートも要らないですが、考える時間無いです、
すいません。
（sy） 2016/04/06(水) 08:26
----
一度整理を。

優先順位
大分類、中分類、小分類
の順でソート。

分類毎のソートは、
件数が違う場合は多い順
件数が同じ場合は一番若い日付で比較して日付の若い順

でしょうか？

件数も日付も同じ場合はどうなるのですか？
名称で昇順か降順にするのか、
県庁所在地順になるのか(この場合予めリストを作っておかないと行けません。)

（sy） 2016/04/06(水) 12:42
----
マリオさま、βさま、γさま、syさま、se_9さま　こんなにも回答ありがとうございます。

これから、コードを当てはめて検証させていただきます。
感謝申し上げます。

 先にお話をせずに申し訳ありませんでした。
都道府県、市区町村にさせていただいたのは、もちろん、会社の項目を使うことができなので、リネームしております。申し訳ありません。

 ＞分類毎のソートは、 
件数が違う場合は多い順 
件数が同じ場合は一番若い日付で比較して日付の若い順
 ---おっしゃる通りです。

 ＞件数も日付も同じ場合はどうなるのですか？ 
 ---件数も日付も同じ場合には、掲載されている順で大丈夫です。
 逆にいうと、どの順番でもOKです。

（aki） 2016/04/06(水) 22:06
----
 To aki さん
 
 住所（県、市、字）は、仮のデータなんですね。はじめから、言ってください。
 
 下記のサンプルを使って、test4,test5のコードを実行してください。
 ex.)B2セル（大分類は、沖縄県）B5セル（大分類は、群馬県）ともに、中分類は「越谷市」。
 
 
 （※日本の住所は、A列（都道府県）が異なれば、必ずB列（市）も異なるので、下記のサンプルはありえない）
 '*******************************************************************************
        [A]     [B]     [C]     [D]   
  [1]   大分類  中分類  小分類  受付日
  [2]   沖縄県  越谷市  越ヶ谷  4/1   
  [3]   沖縄県  越谷市  越ヶ谷  4/2   
  [4]   沖縄県  朝霞市  越ヶ谷  4/1   
  [5]   群馬県  越谷市  中町    4/1   
  [6]   群馬県  越谷市  中町    4/2   
  [7]   群馬県  朝霞市  越ヶ谷  4/1   
  [8]   群馬県  朝霞市  越ヶ谷  4/2   
  [9]   群馬県  朝霞市  越ヶ谷  4/3   
  [10]  栃木県  越谷市  中町    4/1   
  [11]  栃木県  朝霞市  中町    4/1   
  [12]  栃木県  朝霞市  中町    4/2   
  [13]  栃木県  越谷市  中町    4/2   
  '******************************************************************************
（マリオ） 2016/04/07(木) 05:30
----
  'test4のコード内の★印がついている行「Stop」の命令文の前に「'」を追加するとプログラムが途中で止まります。
 'プログラムを途中で止めて、E,F,G列の数字を確認してください。
 
 
 '■概要■
 '(1)セル範囲（A2:D & mx1）において、
 '    「第1優先キー：A列」、「第2優先キー：B列」、「第3優先キー：D列」で並べ替え（昇順）(mx1は最終行）
 '(2)E,F,G列に作業列を挿入
 '(3)E,F,G列にカウント数を書き込む
 '    （ただし、B列のカウントは、A列の文字種別内。同様に、C列のカウントは、B列の文字種別内）
 '(4)セル範囲（A2:G & mx1）において、
 '    「第1優先キー：E列」、「第2優先キー：F列」、「第3優先キー：G列」で並び替え（降順）
 '(5)E,F,G列の作業列を削除
 
 
 '■その他■
 '（注意）test4では、A列とB列の最終行が一致しないと、Do〜Loopから抜け出せなくなります。
 ' test5は、test4に、事前チェック（最終行一致確認、空欄確認）コードを追加したものです。
 画面更新OFF等のコードも追加してます（下記ＵＲＬ先参照）
http://thom.hateblo.jp/entry/2015/08/31/063500

 Option Explicit
 Sub test4()
     Dim sh1 As Worksheet, mx1 As Long, c As Range, rng As Range
     Dim tmp As String, i As Long, j As Long, k As Long
     
     Set sh1 = Sheets("Sheet1")
     mx1 = sh1.Range("A" & Rows.Count).End(xlUp).Row '最終行取得
     With sh1.Sort '並び替え（昇順）
         .SortFields.Clear
         .SortFields.Add Key:=sh1.Range("A2")
         .SortFields.Add Key:=sh1.Range("B2")
         .SortFields.Add Key:=sh1.Range("C2")
         .SortFields.Add Key:=sh1.Range("D2")
         .SetRange sh1.Range("A2:D" & mx1): .Header = xlNo: .Apply
     End With
     sh1.Columns("E:G").Insert '作業列挿入
     sh1.Columns("E:G").NumberFormatLocal = "G/標準"
    '*******************************************************************************
    'E列にA列のカウント数を書き込む
     ReDim Data(2 To mx1, 1 To 1) As Long
     j = 1 '配列のIndex番号（初期値）
     Set rng = sh1.Range("A" & 2 & ":A" & mx1) '2行目〜mx1行目
     For Each c In rng
         j = j + 1: Data(j, 1) = WorksheetFunction.CountIf(rng, c.Value)
     Next c
     sh1.Range("E" & 2 & ":E" & mx1) = Data
    '*******************************************************************************
    '文字種別ごとの「開始行」、「最終行」を取得（A列及びB列）した後、
    'F列にB列の（G列にC列の）カウント数を書き込む
     For k = 1 To 2 '列番号
         ReDim sr(1 To 1) As Long, er(1 To 1) As Long
         j = 1 '配列のIndex番号（初期値）
         sr(j) = 2 '「開始行」（2行目から）
         tmp = sh1.Cells(sr(j), k).Value '（初期値）(文字種別ごとにtmpは変わる）
         
         
         '（注意）A列とB列の最終行が一致しないと、Do〜Loopから抜け出せなくなる
         Do
           For i = sr(j) To mx1 + 1
               If sh1.Cells(i, k).Value <> tmp Then
                  ReDim Preserve er(1 To j): er(j) = i - 1 '「最終行」
                  j = j + 1
                  If i = mx1 + 1 Then Exit Do
                  ReDim Preserve sr(1 To j): sr(j) = i '次の文字種の「開始行」
                  tmp = sh1.Cells(i, k).Value          '次のためにtmpを設定
                  Exit For
            End If
           Next i
         Loop
        '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
         Erase Data: ReDim Data(2 To mx1, 1 To 1) As Long
         j = 1 '配列のIndex番号（初期値）
         For i = 1 To UBound(sr)
             Set rng = sh1.Range(sh1.Cells(sr(i), k + 1), sh1.Cells(er(i), k + 1)) 'B列→C列
             For Each c In rng
                 j = j + 1
                 Data(j, 1) = WorksheetFunction.CountIf(rng, c.Value)
             Next c
         Next i
         sh1.Range(sh1.Cells(2, k + 5), sh1.Cells(mx1, k + 5)) = Data 'F列→G列
         If k = 2 Then Exit For: Erase sr: Erase er
     Next k
    '*******************************************************************************
    
    ' Stop '★★★★★★★
    
     With sh1.Sort '並び替え
         .SortFields.Clear
         .SortFields.Add Key:=sh1.Range("E2"), Order:=xlDescending
         .SortFields.Add Key:=sh1.Range("F2"), Order:=xlDescending
         .SortFields.Add Key:=sh1.Range("G2"), Order:=xlDescending
         .SetRange sh1.Range("A2:G" & mx1): .Header = xlNo: .Apply
     End With
     sh1.Columns("E:G").Delete '作業列削除
 End Sub

 

（マリオ） 2016/04/07(木) 05:30
----
 
 Option Explicit
 Sub test5()
     Dim sh1 As Worksheet, mx1 As Long, c As Range, rng As Range
     Dim tmp As String, i As Long, j As Long, k As Long
     
     Set sh1 = Sheets("Sheet1")
     mx1 = sh1.Range("A" & Rows.Count).End(xlUp).Row '最終行取得
     
     With Application
         .ScreenUpdating = False
         .EnableEvents = False
         .Calculation = xlCalculationManual
     End With
 
    '*****************************************
     Dim C_Cell As String
     C_Cell = sh1.Range("A2:D" & mx1).Address
     Call Check(sh1, C_Cell, mx1) '事前確認
    '*****************************************
     
     With sh1.Sort '並び替え（昇順）
         .SortFields.Clear
         .SortFields.Add Key:=sh1.Range("A2")
         .SortFields.Add Key:=sh1.Range("B2")
         .SortFields.Add Key:=sh1.Range("C2")
         .SortFields.Add Key:=sh1.Range("D2")
         .SetRange sh1.Range("A2:D" & mx1): .Header = xlNo: .Apply
     End With
     
     sh1.Columns("E:G").Insert '作業列挿入
     sh1.Columns("E:G").NumberFormatLocal = "G/標準"
    '*******************************************************************************
    'E列にA列のカウント数を書き込む
     ReDim Data(2 To mx1, 1 To 1) As Long
     j = 1 '配列のIndex番号（初期値）
     Set rng = sh1.Range("A" & 2 & ":A" & mx1) '2行目〜mx1行目
     For Each c In rng
         j = j + 1: Data(j, 1) = WorksheetFunction.CountIf(rng, c.Value)
     Next c
     sh1.Range("E" & 2 & ":E" & mx1) = Data
    '*******************************************************************************
    '文字種別ごとの「開始行」、「最終行」を取得（A列及びB列）した後、
    'F列にB列の（G列にC列の）カウント数を書き込む
     For k = 1 To 2 '列番号
         ReDim sr(1 To 1) As Long, er(1 To 1) As Long
         j = 1 '配列のIndex番号（初期値）
         sr(j) = 2 '「開始行」（2行目から）
         tmp = sh1.Cells(sr(j), k).Value '（初期値）(文字種別ごとにtmpは変わる）
         
         
         '（注意）A列とB列の最終行が一致しないと、Do〜Loopから抜け出せなくなる
         Do
           For i = sr(j) To mx1 + 1
               If sh1.Cells(i, k).Value <> tmp Then
                  ReDim Preserve er(1 To j): er(j) = i - 1 '「最終行」
                  j = j + 1
                  If i = mx1 + 1 Then Exit Do
                  ReDim Preserve sr(1 To j): sr(j) = i '次の文字種の「開始行」
                  tmp = sh1.Cells(i, k).Value          '次のためにtmpを設定
                  Exit For
            End If
           Next i
         Loop
        '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
         Erase Data: ReDim Data(2 To mx1, 1 To 1) As Long
         j = 1 '配列のIndex番号（初期値）
         For i = 1 To UBound(sr)
             Set rng = sh1.Range(sh1.Cells(sr(i), k + 1), sh1.Cells(er(i), k + 1)) 'B列→C列
             For Each c In rng
                 j = j + 1
                 Data(j, 1) = WorksheetFunction.CountIf(rng, c.Value)
             Next c
         Next i
         sh1.Range(sh1.Cells(2, k + 5), sh1.Cells(mx1, k + 5)) = Data 'F列→G列
         If k = 2 Then Exit For: Erase sr: Erase er
     Next k
    '*******************************************************************************
     With sh1.Sort '並び替え
         .SortFields.Clear
         .SortFields.Add Key:=sh1.Range("E2"), Order:=xlDescending
         .SortFields.Add Key:=sh1.Range("F2"), Order:=xlDescending
         .SortFields.Add Key:=sh1.Range("G2"), Order:=xlDescending
         .SetRange sh1.Range("A2:G" & mx1): .Header = xlNo: .Apply
     End With
     sh1.Columns("E:G").Delete '作業列削除
     
     With Application
         .ScreenUpdating = True
         .EnableEvents = True
         .Calculation = xlCalculationAutomatic
     End With
     
 End Sub
 
 '**************************************************************************************
 
 Private Sub Check(ByVal sh As Worksheet, ByVal C_Cell As String, ByVal mx1 As Long)
     Dim mx2 As Long, mx3 As Long, mx4 As Long, cnt As Long
     Dim c As Range, msg As String, msg2 As String
    
    '最終行の一致確認
     mx2 = sh.Range("B" & Rows.Count).End(xlUp).Row
     mx3 = sh.Range("C" & Rows.Count).End(xlUp).Row
     mx4 = sh.Range("D" & Rows.Count).End(xlUp).Row
     If Not (mx1 = mx2 And mx2 = mx3 And mx3 = mx4) Then
        msg2 = "最終行が一致しません" & vbLf & "「" & sh.Name & "」（A,B,C,D列）"
        MsgBox msg2, vbCritical, "終了します": End '終了
     End If
     
    '空欄確認
     For Each c In sh.Range(C_Cell)
         If Trim(c.Value) = "" Then
            cnt = cnt + 1: msg = msg & Replace(c.Address, "$", "") & ","
         End If
     Next c
     If cnt >= 1 Then
        msg = Mid(msg, 1, Len(msg) - 1)
        msg2 = "次のセルが空欄です「" & sh.Name & "」" & vbLf & vbLf
        MsgBox msg2 & msg, vbCritical, "終了します": End '終了
     End If
 End Sub


 
（マリオ） 2016/04/07(木) 05:36
----
おはようございます。

＞件数が違う場合は多い順 
＞件数が同じ場合は一番若い日付で比較して日付の若い順
＞---おっしゃる通りです。

＞---件数も日付も同じ場合には、掲載されている順で大丈夫です。
＞逆にいうと、どの順番でもOKです。

上記の条件でしたら、下記コードでご希望に添えます。

関数部分を、全ての分類で件数に日付要素を追加しました。
関数考えるより2回ソートする方が記述楽なので、後はそのままにしています。
データ数が非常に多くて時間がかかると言うのでしたら、1回ソートで済むように関数部分を考えてみます。

 Sub test()
    Dim lRow As Long

    lRow = Range("A" & Rows.Count).End(xlUp).Row

    With Sheets("Sheet1").Sort
        .SortFields.Clear
        .SortFields.Add key:=Range("D2"), Order:=xlAscending
        .SetRange Range("A1:D" & lRow)
        .Header = xlYes
        .Apply
    End With

    Range("E:G").Insert
    Range("E2:E" & lRow).Formula = "=COUNTIF(A:A,A2)-INDEX(D:D,MATCH(A2,A:A,0))/100000"
    Range("F2:F" & lRow).Formula = "=COUNTIF(B:B,B2)-INDEX(D:D,MATCH(B2,B:B,0))/100000"
    Range("G2:G" & lRow).Formula = "=COUNTIF(C:C,C2)-INDEX(D:D,MATCH(C2,C:C,0))/100000"
    Range("E2:G" & lRow).Value = Range("E2:G" & lRow).Value

    With Sheets("Sheet1").Sort.SortFields
        .Clear
        .Add key:=Range("E2"), Order:=xlDescending
        .Add key:=Range("F2"), Order:=xlDescending
        .Add key:=Range("G2"), Order:=xlDescending
    End With
    With Sheets("Sheet1").Sort
        .SetRange Range("A1:G" & lRow)
        .Header = xlYes
        .Apply
    End With

    Range("E:G").Delete

 End Sub

（sy） 2016/04/07(木) 05:41
----
To マリオさん

＞（※日本の住所は、A列（都道府県）が異なれば、必ずB列（市）も異なるので、下記のサンプルはありえない）
今回のケースではその部分は問題ではありません。
分類中で件数が2件以上で同じ件数の分類名が複数ある場合のソートルールが、COUNTIFだけでは正しくソートが出来ないんです。

（sy） 2016/04/07(木) 05:59
----
 To sy さん
 
 おはようございます。
 う〜む。なんだかよく分からない。
 住所は、仮のデータだということらしいですが、
 ★大分類（A列）が異なれば、中分類(B列)が同じ文字列になることはないといえますかね？ 
 そこんところ、もう一度、akiさんに確認したいな。
 

 >同じ件数の分類名が複数ある場合のソートルール
 
 同じ件数なら、あいうえお順にしたいってことですよね？
 件数は、最後に降順で並び替えるのに、
 同じ件数の文字列は昇順にしたいのだから、
 降順と昇順が、ごちゃ混ぜですよね。
 
 E,F,G列の作業列にデータを書き込む前に、昇順で並び替えをしてますが、
 その昇順並び替えで、D列だけでなく、A列,B列,C列も並び替えればいいのでは？
 
 
 To aki さん
 ★大分類（A列）が異なれば、中分類(B列)が同じ文字列になることは絶対にないですか？ 
 
（マリオ） 2016/04/07(木) 06:31
----
 To　マリオさん

 ちょっと違いますね。

 ＞同じ件数の分類名が複数ある場合のソートルール

 この部分は各分類毎に考えて、

 1番目、違う件数の場合は、日付要素を無視して件数の多い順
        (COUNTIFだけのEFG列で降順)
 2番目、同じ件数だった場合は、D列の日付で一番過去の日付
        (表現悪かったから変えました)を持つ分類名が上にくる
        (こっちは件数同じなので日付のみ昇順)
        (但し2件以上の時は日付だけだと分類名が江東区、足立区、江東区、足立区
         みたいになるので、件数と日付を別ルールにすると正しくソートされません)

 と言う事です。
 件数によって1つのルール内で2種類のルールが存在すると言う事です。


（sy） 2016/04/07(木) 07:11
----
 あっ、うっかりしてました。
件数日付が全て一致の時のルールが抜けてました。
下記でお願いします。 

 Sub test()

    Dim lRow As Long
    lRow = Range("A" & Rows.Count).End(xlUp).Row

    With Sheets("Sheet1").Sort
        .SortFields.Clear
        .SortFields.Add key:=Range("D2"), Order:=xlAscending
        .SetRange Range("A1:D" & lRow)
        .Header = xlYes
        .Apply
    End With

    Range("E:G").Insert
    Range("E2:E" & lRow).Formula = "=COUNTIF(A:A,A2)-INDEX(D:D,MATCH(A2,A:A,0))/100000"
    Range("F2:F" & lRow).Formula = "=COUNTIF(B:B,B2)-INDEX(D:D,MATCH(B2,B:B,0))/100000"
    Range("G2:G" & lRow).Formula = "=COUNTIF(C:C,C2)-INDEX(D:D,MATCH(C2,C:C,0))/100000"
    Range("E2:G" & lRow).Value = Range("E2:G" & lRow).Value

    With Sheets("Sheet1").Sort.SortFields
        .Clear
        .Add key:=Range("E2"), Order:=xlDescending
        .Add key:=Range("A2")
        .Add key:=Range("F2"), Order:=xlDescending
        .Add key:=Range("B2")
        .Add key:=Range("G2"), Order:=xlDescending
        .Add key:=Range("C2")
    End With
    With Sheets("Sheet1").Sort
        .SetRange Range("A1:G" & lRow)
        .Header = xlYes
        .Apply
    End With

    Range("E:G").Delete

 End Sub
（sy） 2016/04/07(木) 08:11
----
みなさまありがとうございます。
 以下の部分取り急ぎ回答させていただきます。
また、サンプルというコメントせず本当に申し訳ありませんでした。
深くお詫び申しあげます。

読解力がなく申し訳ありません。
  To aki さん
 ★大分類（A列）が異なれば、中分類(B列)が同じ文字列になることは絶対にないですか？ 
可能性はあります。B列の項目には必ず、その他というものがあります。
自分の中では、全て多い順に並び替えた後、A&B&Cとつなげて、日付順に並び替えるイメージ
だったのですが、そんなに甘いものではありませんでした。
帰宅後いただいたコードを検証いたします。
本当にありがとうございます。
（aki） 2016/04/07(木) 22:18
----
 To マリオさん

 akiさんの、
 ＞A&B&Cとつなげて、日付順に並び替えるイメージ
 これを見たら、私もまだ勘違いしている可能性があると思いました。

 分かったつもりになって失礼申し上げて大変申し訳ありませんでした。
 心よりお詫び申し上げます。

 To akiさん

 追加質問ですが、

 優先順位が大分類、中分類、小分類ではなく、
 大分類、大分類＆中分類、大分類＆中分類＆小分類で多い順。
 同じ場合は一番過去の日付で比較して、過去の日付順。

 と言う事でしょうか？

 もしそういう事でしたら、関数部分を変更して以下になります。

 Sub test()
    Dim lRow As Long
    
    lRow = Range("A" & Rows.Count).End(xlUp).Row

    With Sheets("Sheet1").Sort
        .SortFields.Clear
        .SortFields.Add key:=Range("D2"), Order:=xlAscending
        .SetRange Range("A1:D" & lRow)
        .Header = xlYes
        .Apply
    End With

    Range("E:G").Insert
    Range("E2:E" & lRow).Formula = "=COUNTIF(A:A,A2)-INDEX(D:D,MATCH(A2,A:A,0))/100000"
    Range("F2:F" & lRow).Formula = "=COUNTIFS(A:A,A2,B:B,B2)-INDEX(D:D,INDEX(MATCH(A2&B2,$A$1:$A$" & lRow & "&$B$1:$B$" & lRow & ",0),))/100000"
    Range("G2:G" & lRow).Formula = "=COUNTIFS(A:A,A2,B:B,B2,C:C,C2)-INDEX(D:D,INDEX(MATCH(A2&B2&C2,$A$1:$A$" & lRow & "&$B$1:$B$" & lRow & "&$C$1:$C$" & lRow & ",0),))/100000"
    Range("E2:G" & lRow).Value = Range("E2:G" & lRow).Value

    With Sheets("Sheet1").Sort.SortFields
        .Clear
        .Add key:=Range("E2"), Order:=xlDescending
        .Add key:=Range("A2")
        .Add key:=Range("F2"), Order:=xlDescending
        .Add key:=Range("B2")
        .Add key:=Range("G2"), Order:=xlDescending
        .Add key:=Range("C2")
    End With
    With Sheets("Sheet1").Sort
        .SetRange Range("A1:G" & lRow)
        .Header = xlYes
        .Apply
    End With

    Range("E:G").Delete

 End Sub





（sy） 2016/04/07(木) 23:15
----
syさま　ありがとうございます。

 ＞分かったつもりになって失礼申し上げて大変申し訳ありませんでした。
心よりお詫び申し上げます。

 本当にごめんなさい。無力な自分にこんなに親切に丁寧にしてくださって。
本当に感謝の気持ちでいっぱいです。ありがとうございます。
お詫びなんてとんでもございません。
どうかご勘弁下さい。

仰る通りです。
 完璧動きました。ありがとうございます。
感謝の気持ちでいっぱいです。

重ね重ね恐れ入ります
 ABCDで並び替えは完璧にできました。
しかしながら、データを確認すると、
A列からZ列まで使用していることがわかり、
上記を実行したら、A344以下に上記の結果が残り、D列からZ列まではそのまま残ったままでした。
大変恐縮なのですが、D列以降もABCDの条件のまま一緒に並び替えをするにはどこのコードを変更すれば
宜しいのでしょうか？よろしくお願いします。

（aki） 2016/04/08(金) 00:04
----
 To aki さん、To sy さん
 
 ＞自分の中では、全て多い順に並び替えた後、A&B&Cとつなげて、日付順に並び替えるイメージ
 
 それで、ほぼ並び替えられると思いますが、イレギュラーなケースとして次のような場合が考えられます。
 ありえないでしょうから、考えなくていいのかな？？
 
 大分類「ああ」、中分類「いい」、小分類「うう」
 大分類「あ」、中分類「あい」、小分類「いうう」

 ん？つなげちゃダメか？ん？

（マリオ） 2016/04/08(金) 00:07
----
  To aki さん
 
 ＞A列からZ列まで使用していることがわかり、
 
 test4、test5で次のように修正してください。
 
 
 前半の並び替え
 ■修正前
 .SetRange sh1.Range("A2:D" & mx1): .Header = xlNo: .Apply
 ■修正後
 .SetRange sh1.Range("A2:Z" & mx1): .Header = xlNo: .Apply
 ****************************************************************
 後半の並び替え
 ■修正前
 .SetRange sh1.Range("A2:G" & mx1): .Header = xlNo: .Apply
 ■修正後
 .SetRange sh1.Range("A2:AC" & mx1): .Header = xlNo: .Apply
（マリオ） 2016/04/08(金) 00:14
----
 To マリオさん

 今までの式では文字は繋げていないのでそれは大丈夫でした。

 To akiさん

 私のコードの下の方に記述している
        .SetRange Range("A1:G" & lRow)
 の部分を、
        .SetRange Range("A1:AC" & lRow)
 に変更して実行してみて下さい。

 それでご希望の結果になればOKですし、
 イメージと違う場合は、どの列がどう違うのか、出来ればレイアウトを添えて教えて下さい。



（sy） 2016/04/08(金) 01:47
----
 To akiさん

 間違えました。

 私のコードで2か所修正して下さい。
 １個所目は上のソートの
        .SetRange Range("A1:D" & lRow)
 の部分を、
        .SetRange Range("A1:Z" & lRow)
 に変更して、

 2箇所目は下のソートの、
        .SetRange Range("A1:G" & lRow)
 の部分を、
        .SetRange Range("A1:AC" & lRow)
 に変更して実行してみて下さい。

（sy） 2016/04/08(金) 01:55
----
 sy さん
 
 ＞優先順位が大分類、中分類、小分類ではなく、
 ＞大分類、大分類＆中分類、大分類＆中分類＆小分類で多い順。
 ＞同じ場合は一番過去の日付で比較して、過去の日付順。
 
 この法則で並び替えれば、
 「大分類（A列）が異なるけど、中分類(B列)で同じ文字列」（例えば、「その他」）
 に対応できますね。コードもコンパクトになりそうですね。
 作業列をE,F,G,H,Iと設けたらFormulaの式、もっと簡単になりませんか？
 
 
 作業列をE,F,Gに書き込むをする前に、H,I列に書き込み。
 H列は、「大分類＆中分類」
 I列は、「大分類＆中分類＆小分類」
 F列の数式は、H列参照。G列の数式は、I列参照。

 あと、D列の並び替えも、最後の並び替えでやればいいのでは？

（マリオ） 2016/04/08(金) 02:52
----
 To マリオさん

 ＞作業列をE,F,G,H,Iと設けたらFormulaの式、もっと簡単になりませんか？
 ＞作業列をE,F,Gに書き込むをする前に、H,I列に書き込み。
 ＞H列は、「大分類＆中分類」
 ＞I列は、「大分類＆中分類＆小分類」
 ＞F列の数式は、H列参照。G列の数式は、I列参照。

 確かに、おっしゃる通りですね。
 文字繋げてCOUNTIFとMATCHの単純な組み合わせで行けました。

    Range("E:I").Insert
    Range("E2:E" & lRow).Formula = "=COUNTIF(A:A,A2)-INDEX(D:D,MATCH(A2,A:A,0))/100000"
    Range("F2:F" & lRow).Formula = "=COUNTIF(H:H,H2)-INDEX(D:D,MATCH(H2,H:H,0))/100000"
    Range("G2:G" & lRow).Formula = "=COUNTIF(I:I,I2)-INDEX(D:D,MATCH(I2,I:I,0))/100000"
    Range("H2:H" & lRow).Formula = "=A2&"",""&B2"
    Range("I2:I" & lRow).Formula = "=A2&"",""&B2&"",""&C2"
    Range("E2:I" & lRow).Value = Range("E2:I" & lRow).Value

 ただ文字を繋げる場合は、

 ＞大分類「ああ」、中分類「いい」、小分類「うう」
 ＞大分類「あ」、中分類「あい」、小分類「いうう」

 これだけは注意しないとだめですね。

 後、上記では,で区切りましたけど、実際の文字列に,があると使えないのが欠点ですね。
 絶対に使用しない区切り文字にしないと。。。

 初めのD列の並べ替えは、MATCH検索の式を簡単にする為です。
 
（sy） 2016/04/08(金) 03:42
----
 To akiさん

 こちらの方が動作も軽くて良いですので、こちらでお願いします。
 それと先程のコードは、マリオさんのご指摘の、

 ＞大分類「ああ」、中分類「いい」、小分類「うう」
 ＞大分類「あ」、中分類「あい」、小分類「いうう」

 に対しての回避処置を忘れていました。
 申し訳ありません。
 
 ただ下記コードはAからC列の文字中に半角の,(カンマ)があると使用できません。
 もし,があるようでしたら、絶対に文字として使用しない区切り用の文字を教えて下さい。

 Sub test2()
    Dim lRow As Long

    lRow = Range("A" & Rows.Count).End(xlUp).Row

    With Sheets("Sheet1").Sort
        .SortFields.Clear
        .SortFields.Add key:=Range("D2"), Order:=xlAscending
        .SetRange Range("A1:Z" & lRow)
        .Header = xlYes
        .Apply
    End With

    Range("E:I").Insert
    Range("E2:E" & lRow).Formula = "=COUNTIF(A:A,A2)-INDEX(D:D,MATCH(A2,A:A,0))/100000"
    Range("F2:F" & lRow).Formula = "=COUNTIF(H:H,H2)-INDEX(D:D,MATCH(H2,H:H,0))/100000"
    Range("G2:G" & lRow).Formula = "=COUNTIF(I:I,I2)-INDEX(D:D,MATCH(I2,I:I,0))/100000"
    Range("H2:H" & lRow).Formula = "=A2&"",""&B2"
    Range("I2:I" & lRow).Formula = "=A2&"",""&B2&"",""&C2"
    Range("E2:I" & lRow).Value = Range("E2:I" & lRow).Value
    
    With Sheets("Sheet1").Sort.SortFields
        .Clear
        .Add key:=Range("E2"), Order:=xlDescending
        .Add key:=Range("A2")
        .Add key:=Range("F2"), Order:=xlDescending
        .Add key:=Range("B2")
        .Add key:=Range("G2"), Order:=xlDescending
        .Add key:=Range("C2")
    End With
    With Sheets("Sheet1").Sort
        .SetRange Range("A1:AE" & lRow)
        .Header = xlYes
        .Apply
    End With

    Range("E:I").Delete

 End Sub

（sy） 2016/04/08(金) 03:52
----
 To sy さん

 ＞後、上記では,で区切りましたけど、実際の文字列に,があると使えないのが欠点ですね。
 
 過去に、「重複チェックをする別案件」で、Tab文字を区切り文字にして繋げることをβさんがしていました。
 これも同様に、実際の文字列に「Tab文字」があると使えないのですが。
 
  (1) 大分類「ああ」、中分類「いい」、小分類「うう」
  (2) 大分類「あ」、中分類「あい」、小分類「いうう」
  Tab文字を「■」で表現すると、どちらも「ああ■いい■うう」ですもんね。
  そんなケースは、なさそうなんで、何かしらの区切り文字「カンマとかTab文字」で繋いでおけば、大丈夫でしょう!(^^)!
 
 
 ＞初めのD列の並べ替えは、MATCH検索の式を簡単にする為です。
 式を理解してないですが、そのためだったんですね
（マリオ） 2016/04/08(金) 12:29
----
  To aki さん
 
 データは、何行ぐらいあるんでしょうか？
 
 *************************************************************************************
 ★以下、遊んでいるだけなので、コメントはいりません。
 サンプルデータ作成マクロ
 Sheet1の（列：A〜Z列、行：1〜10000）に、「あ」〜「ん」の文字を入れます（乱数）。
 このサンプルを使うと、test4,test5ともに、並べ替えに要する時間は、(15秒ぐらい)
 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 Declare Function GetTickCount Lib "KERNEL32.DLL" () As Long
 Sub サンプルデータ作成()
     Const x As Long = 10000 '★1万件
     Dim StartTime As Long: StartTime = GetTickCount '■時間計測開始（ミリ秒）
     Dim sh1 As Worksheet, rng As Range, Str As String
     Dim i As Long, r As Long, c As Long, k As Long
     ReDim Data(1 To x - 1, 1 To 26)
     Set sh1 = Sheets("Sheet1") '★
     
     Set rng = Intersect(sh1.Range("A1", sh1.UsedRange), _
                         sh1.Range("A1", sh1.UsedRange).Offset(1))
     If Not (rng Is Nothing) Then rng.ClearContents '2行目より下を削除
     
   
     For c = 1 To 26        '列（A〜Z：1〜26）「配列内」
         For r = 1 To x - 1 '行（1〜x-1）     「配列内」
            '+++++++++++++++++++++++++++++++++++++++++++++++++++++
             Str = ""
             For i = 1 To 1 '1文字
                '177〜221の数字（乱数）
                 k = Int((221 - 177 + 1) * Rnd + 177)
                'Chr(177)は「あ」,Chr(221)は「ん」
                 Str = Str + StrConv(Chr(k), vbHiragana + vbWide)
             Next i
             Data(r, c) = Str
            '+++++++++++++++++++++++++++++++++++++++++++++++++++++
         Next r
     Next c
     
     sh1.Range(sh1.Cells(2, 1), sh1.Cells(x, 26)).Value = Data
     Set sh1 = Nothing: Set rng = Nothing
     MsgBox (GetTickCount - StartTime) & "[ミリ秒]" '■時間計測終了（ミリ秒）
 End Sub
（マリオ） 2016/04/08(金) 12:32
----
   
    ★以下、遊んでいるだけなので、コメントはいりません。
    Sheet1にデータがあるとします。（データは並び替えられてなくても構いません。）

    Sheet2に、「大分類」、「中分類」、「小分類」の件数をピボットテーブルで表示するマクロ(Excel2007以降)です。
    （Sheet1のA列、B列、C列のデータしか使いません。またD列を挿入して作業列にします。後でD列削除。）
   （動作確認環境：Excel2013）
  'Excel2007    Version:=xlPivotTableVersion12
  'Excel2013    Version:=xlPivotTableVersion15
   
 Sub 新規シートにピボットテーブル作成2() 'Excel2007以降
     Dim ws As Worksheet, pvc As PivotCache, pvt As PivotTable
     Dim sh As Worksheet, mx As Long, i As Long
     Dim ad As String, S_Data As String, rng As Range
     Dim title1 As String, title2 As String, title3 As String, title4 As String
     
     Set sh = Sheets("Sheet1") '★並べ替えられたデータがあるシート
     mx = sh.Range("A" & Rows.Count).End(xlUp).Row
    'D列***************************************
     sh.Columns("D").Insert '列挿入
     sh.Range("D1").Value = "件数"
     ReDim x(1 To mx - 1, 1 To 1)
     For i = 1 To mx - 1
         x(i, 1) = 1
     Next i
     sh.Range("D2:D" & mx).Value = x
     '******************************************
     Set ws = Sheets("Sheet2") '★ピボットテーブル表示シート
     Set rng = ws.UsedRange
     If Not (rng Is Nothing) Then rng.Clear
     
     ad = sh.Range("A1:D" & mx).Address
     S_Data = sh.Name & "!" & Application.ConvertFormula(ad, xlA1, xlR1C1)
     Set pvc = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
                                                 SourceData:=S_Data, _
                                                 Version:=xlPivotTableVersion12)
     
     Set pvt = pvc.CreatePivotTable(TableDestination:=ws.Name & "!R3C1", _
                                    TableName:="ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ2", _
                                    DefaultVersion:=xlPivotTableVersion12)
     title1 = sh.Range("A1").Value
     title2 = sh.Range("B1").Value
     title3 = sh.Range("C1").Value
     title4 = sh.Range("D1").Value
     With pvt.PivotFields(title1)
         .Orientation = xlRowField
         .Position = 1
     End With
     With pvt.PivotFields(title2)
         .Orientation = xlRowField
         .Position = 2
     End With
     With pvt.PivotFields(title3)
         .Orientation = xlRowField
         .Position = 3
     End With
     pvt.AddDataField pvt.PivotFields(title4), "合計 / " & title4, xlSum
     pvt.PivotFields(title1).ShowDetail = False '閉じる
     pvt.PivotFields(title2).ShowDetail = False '閉じる
     sh.Columns("D").Delete '列削除
     ws.Activate
     Set ws = Nothing: Set sh = Nothing:: Set rng = Nothing
 End Sub
 *******************************************************************
 サンプルファイルを置いておきます。
 （ダウンロードパスワード：abc）
 多い順に並び替え（大分類、中分類、小分類）ピボットテーブル.xlsm
http://ww10.puny.jp/uploader/download/1460096785.zip 


（マリオ） 2016/04/08(金) 15:28
----
syさま
 コメントありがとうございます。","も"、"も存在ませんから大丈夫です。
本当にありがとうございます。

マリオさま
 モンスターマクロありがとうございます。
マリオさまって何者ですが？尋常な思考回路ではないような気がしてなりません。
本当にありがとうございます。

お二人さま
 感謝の気持ちでしかありません。お付き合いをいただきありがとうございます。
しっかりと検証いたします。
（aki） 2016/04/08(金) 18:26
----
マリオさま 
 コメント漏れました。すいません。
データは、約12000行です。
（aki） 2016/04/08(金) 18:31
----
 書き込みしましたが、勘違いしていましたので取り消しました。
 どうも失礼。

（γ)   2016/04/08(金) 22:45
----
 こんばんわ。

 ＞データは、約12000行です。

 そんなにあったんですね！！！
 じゃあ私のコードでは2分くらいかかってるんじゃ。。。
 勝手に1000件くらいと想定していました。
 初めに確認しておけば良かったです、申し訳ありません。
 少しでも早く処理できるコードを考えてみますが、上級者の方なら出来ると思いますが、
 私では今回のような複雑なソート条件では、 あまり速いコードを考えれないかも。。。

 取り敢えずですが、私のコードの一番先頭
    Dim lRow As Long
 の下に、
    Application.ScreenUpdating = False
 を記述して頂いて、
 End Sub
 の上に、
    Application.ScreenUpdating = True
 を記述して下さい。

 それで、私のPCで71秒くらいなので、そこそこ速いPCなら40秒くらいにはなると思います。


（sy） 2016/04/08(金) 23:28
----
 気休め程度ですが、

    Range("E:I").Insert
    Range("E2:E" & lRow).Formula = "=COUNTIF(A:A,A2)-INDEX(D:D,MATCH(A2,A:A,0))/100000"
    Range("F2:F" & lRow).Formula = "=COUNTIF(H:H,H2)-INDEX(D:D,MATCH(H2,H:H,0))/100000"
    Range("G2:G" & lRow).Formula = "=COUNTIF(I:I,I2)-INDEX(D:D,MATCH(I2,I:I,0))/100000"
    Range("H2:H" & lRow).Formula = "=A2&"",""&B2"
    Range("I2:I" & lRow).Formula = "=A2&"",""&B2&"",""&C2"
    Range("E2:I" & lRow).Value = Range("E2:I" & lRow).Value

 の関数式の部分を、

    Range("E:I").Insert
    Range("E2").Formula = "=COUNTIF($A$2:$A$15000,A2)-INDEX($D$1:$D$15000,MATCH(A2,$A$1:$A$15000,0))/100000"
    Range("F2").Formula = "=COUNTIF($H$2:$H$15000,H2)-INDEX($D$1:$D$15000,MATCH(H2,$H$1:$H$15000,0))/100000"
    Range("G2").Formula = "=COUNTIF($I$2:$I$15000,I2)-INDEX($D$1:$D$15000,MATCH(I2,$I$1:$I$15000,0))/100000"
    Range("H2").Formula = "=A2&"",""&B2"
    Range("I2").Formula = "=A2&"",""&B2&"",""&C2"
    Range("E2:I2").Copy Range("E3:I" & lRow)
    Range("E2:I" & lRow).Value = Range("E2:I" & lRow).Value

 に変更してもらうと、20%くらいは速くなります。
 全てのセルに直接書き込みよりもコピーの方が若干速かったのと、
 列全体指定は無駄なので15000行に変更して参照領域を狭めました。

（sy） 2016/04/09(土) 03:00
----

 To sy さん
 
 Range("E2").Formula = "=COUNTIF($A$2:$A$15000,A2)-INDEX($D$1:$D$15000,MATCH(A2,$A$1:$A$15000,0))/100000"
 Range("F2").Formula = "=COUNTIF($H$2:$H$15000,H2)-INDEX($D$1:$D$15000,MATCH(H2,$H$1:$H$15000,0))/100000"
 Range("G2").Formula = "=COUNTIF($I$2:$I$15000,I2)-INDEX($D$1:$D$15000,MATCH(I2,$I$1:$I$15000,0))/100000"
 ***********************************************************************************************************
 参照領域をlRow行にしたいときは、次のような感じですかね。式を一度xに入れてやります。
 
 Dim x As String
 x = "=COUNTIF($A$2:$A$" & lRow & ",A2)-INDEX($D$1:$D$" & lRow & ",MATCH(A2,$A$1:$A$" & lRow & ",0))/100000"
 Range("E2").Formula = x
 x = "=COUNTIF($H$2:$H$" & lRow & ",H2)-INDEX($D$1:$D$" & lRow & ",MATCH(H2,$H$1:$H$" & lRow & ",0))/100000"
 Range("F2").Formula = x
 x = "=COUNTIF($I$2:$I$" & lRow & ",I2)-INDEX($D$1:$D$" & lRow & ",MATCH(I2,$I$1:$I$" & lRow & ",0))/100000"
 Range("G2").Formula = x


 To aki さん
 解決でいいですかね(^^♪


（マリオ） 2016/04/09(土) 05:08
----
 To akiさん

 変数と関数の併用で10秒ちょっとくらいまで速くなりました。
 
  Sub test3()
    Dim lRow As Long
    Dim x As String
    Dim t As Double

    t = Timer
    Application.ScreenUpdating = False

    lRow = Range("A" & Rows.Count).End(xlUp).Row

    With Sheets("Sheet1").Sort
        .SortFields.Clear
        .SortFields.Add key:=Range("D2"), Order:=xlAscending
        .SetRange Range("A1:Z" & lRow)
        .Header = xlYes
        .Apply
    End With

    Range("E:L").Insert
    Range("H2:H" & lRow).Formula = "=A2&"",""&B2"
    Range("I2:I" & lRow).Formula = "=A2&"",""&B2&"",""&C2"
    Range("L:L").NumberFormatLocal = "G/標準"
    Range("L2").Value = 1
    Range("L3").Value = 2
    Range("L2:L3").AutoFill Destination:=Range("L2:L" & lRow), Type:=xlFillDefault
    Range("J1:J" & lRow).Value = Range("A1:A" & lRow).Value
    Range("D1:D" & lRow).Copy Range("K1")
    Call ConditionsSet(lRow, "E2:E")
    Range("J1:J" & lRow).Value = Range("H1:H" & lRow).Value
    Call ConditionsSet(lRow, "F2:F")
    x = "=COUNTIF($I$2:$I$" & lRow & ",I2)-INDEX($D$1:$D$" & lRow & ",MATCH(I2,$I$1:$I$" & lRow & ",0))/100000"
    Range("G2:G" & lRow).Formula = x
    Range("G2:G" & lRow).Value = Range("G2:G" & lRow).Value

    With Sheets("Sheet1").Sort.SortFields
        .Clear
        .Add key:=Range("E2"), Order:=xlDescending
        .Add key:=Range("A2")
        .Add key:=Range("F2"), Order:=xlDescending
        .Add key:=Range("B2")
        .Add key:=Range("G2"), Order:=xlDescending
        .Add key:=Range("C2")
    End With
    With Sheets("Sheet1").Sort
        .SetRange Range("A1:AH" & lRow)
        .Header = xlYes
        .Apply
    End With

    Range("E:L").Delete

    Application.ScreenUpdating = True
    Debug.Print Timer - t

 End Sub

 Sub ConditionsSet(RowNo As Long, strCol As String)
    Dim i As Long, j As Long, k As Long
    Dim d() As Double
    Dim buf As Double
    Dim r As Range

    With Sheets("Sheet1").Sort
        .SortFields.Clear
        .SortFields.Add key:=Range("J2"), Order:=xlAscending
        .SortFields.Add key:=Range("K2"), Order:=xlAscending
        .SetRange Range("J1:L" & RowNo)
        .Header = xlYes
        .Apply
    End With

    Set r = Range("J2:K" & RowNo)
    ReDim d(1 To RowNo - 1, 0)

    i = 1
    Do Until i > RowNo - 1
        j = WorksheetFunction.CountIf(Range("J:J"), r(i, 1))
        buf = j - r(i, 2) / 100000
        r(i, 1).Resize(j) = buf
        i = i + j
    Loop

    With Sheets("Sheet1").Sort
        .SortFields.Clear
        .SortFields.Add key:=Range("L2"), Order:=xlAscending
        .SetRange Range("J1:L" & RowNo)
        .Header = xlYes
        .Apply
    End With

    Range(strCol & RowNo).Value = Range("J2:J" & RowNo).Value

 End Sub


 To マリオさん

 単に文字や数式を範囲に一括書込みする時も変数に入れた方が速いんですね。
 セルへの直接操作や参照とかだけだと思ってました。

 式の意味はそんなに難しくないです。
 例えば下の例があったとして、
  
 |大分類|中分類|小分類|受付日
 |A     |C     |E     |4/3
 |A     |C     |E     |4/1
 |A     |B     |D     |4/2
 |A     |B     |D     |4/4

 並べ替えルールを2つに分けると、COUNTIFでの個数は中分類、小分類とも2個なので機能しないので、
 日付だけが有効になると、下のように中分類と小分類の順番がおかしくなるのと、

 |大分類|中分類|小分類|受付日
 |A     |C     |E     |4/1
 |A     |B     |D     |4/2
 |A     |C     |E     |4/3
 |A     |B     |D     |4/4

 分類名を日付より優先させると、下のように受付日が4/2の方が4/1より上に来てしまいます。

 |大分類|中分類|小分類|受付日
 |A     |B     |D     |4/2
 |A     |B     |D     |4/4
 |A     |C     |E     |4/1
 |A     |C     |E     |4/3

 なので1つのルールで個数+日付にする為にCOUNTIFを整数部分、MATCHを小数部分にして合わせることで、
 個数＞日付の優先順位で、1つのルールに纏めています。

 ただ最優先の個数が降順なので、MATCHは引き算になっています。

（sy） 2016/04/09(土) 17:38
----
 To sy さん
 >単に文字や数式を範囲に一括書込みする時も変数に入れた方が速いんですね。
 Dim x As Stringですかね？ん？
 書きやすいだけです（ダブルクオテーション「"」処理が大変なので）。速くなりません。
 
 
 Range(■).Formula = ●
 の「セルに数式を書き込む処理」は、数が多いとどうしても、遅くなっちゃいますよね。
 
 処理を速くするなら、
 WorksheetFunctionの利用と
 セルへのデータ書き込みを少なくするため、2次元配列の利用
 がどうしても必要だと思います。
 
 式の意味、３回見て、理解できない（＞＿＜）
（マリオ） 2016/04/09(土) 18:27
----
 To マリオさん

 ＞書きやすいだけです（ダブルクオテーション「"」処理が大変なので）。速くなりません。

 そうでしたか、試して微妙に速かったからそうなのかと思った。
 誤差ですね。

 式そのものの説明を簡略したのがまずかったかな？
 作業列を増やせばルールを分けても大丈夫です。
 先程の例を使って、
 |大分類|中分類|小分類|受付日
 |A     |C     |E     |4/3
 |A     |C     |E     |4/1
 |A     |B     |D     |4/2
 |A     |B     |D     |4/4

 受付日に、 |A     |C     |E     |4/1　と、一番過去の日付があるので、下のように並べたいのですが、

 |大分類|中分類|小分類|受付日
 |A     |C     |E     |4/1
 |A     |C     |E     |4/3
 |A     |B     |D     |4/2
 |A     |B     |D     |4/4

 ここで問題になるのが、個数が同じなので個数による並べ替えが行われないと言う事と、
 |A     |C     |E     |4/3　が、 |A     |B     |D     |4/2　より最近の日付と言う事です。
 日付で並べ替える時に先程みたいに、順番がおかしくなります。
 分類名は名前によって先程みたいに、日付を無視して上下逆転する事があるので優先は一番最後にしないといけません。

 これを正しく並べ替えるには、分類毎に日付用作業列を追加して、

 |大分類|中分類|小分類|受付日|→|作業列|
 |A     |C     |E     |4/1   |→|4/1   |
 |A     |C     |E     |4/3   |→|4/1   |
 |A     |B     |D     |4/2   |→|4/2   |
 |A     |B     |D     |4/4   |→|4/2   |

 上記のような日付を追加してあげれば、作業列を優先にして並べ替え、
 次に受付日で並べ変えると、ルールを分けても正しく並べ替えられます。
 ただ分類の要素毎に一番過去の日付は変わるので、この場合作業列が3列必要になります。

 私の式中のMATCHはこの作業列の日付を表しています。
 初めに受付日で並べ替えたのは、同じ分類の中で一番過去の日付が一番上にあるとは限らないので、
 配列数式などで検索するより、先に昇順にしておけば、MATCHの完全一致で一番上の値を拾えば済む為です。

 上記の例では個数は2(COUNTIFをそのまま整数で表示)、
 MATCHの作業列の日付は、4/1が42461、4/2が42462 なので、
 /100000で、0.42461 と、0.42462 になるので、
 個数からそれぞれ引くと、2-0.42461=1.57539、2-0.42462=1.57538 になるので、
 そのまま降順で並べ替えると4/1の方が上にくると言う事です。
 MATCHの結果を少数にしてるので、個数が1の要素などは下に来るので、個数＞日付が成立します。
 
 同じ分類名中の4/1と4/3の順番は、初めに日付で昇順にしてるので、最後にする必要は無いです。

 この作業列を増やしても、使ってる関数は同じなので、速度的にも変わらないだろうし、
 列が増えすぎたらコードの記述も増えるし、列の挿入削除などの範囲も増えるので、
 式を纏める方が効率が良いんです。

（sy） 2016/04/09(土) 19:13
----
マリオさま　syさま

（sy） 2016/04/08(金) 03:52 
 のレスにて無事に動きました。ありがとうございました。(15000に変更したもの)

 長時間にわたりありがとうございました。
無事に解決するとともに、興味深く読ませていただきましたが、まだまだ理解ができません。
もっと熟読したいと思います。

追
 実は、コピーしたものに空白行が文字の上部に出る現象が発生しまして、、
しかしながら、オートフィルで空白を無くし対応しております。
本当にありがとうございました。


（aki） 2016/04/10(日) 00:11
----
 To sy さん
 just a moment!
（マリオ） 2016/04/10(日) 19:49