[[20061019164312]]　『ならべかえ』現在やりたい事　ページの最後に飛ぶ

『ならべかえ』現在やりたい事

    A            A
１ 青木      １青木
２ 鈴木      ２鈴木
３ 吉村   ⇒ ３吉村
４ 青木    
５ 青木
６ 鈴木
上記の様に数の多い順に並べた上、それぞれかぶっているものを一つずつにしたいです。
（まるまるまる）

 A列を選択→データ→フィルタ→フィルタオプションの設定→「指定した範囲」「B1」→「重複するレコードは無視する」にチェック
 後で、A列を削除

 では、いかがでしょうか？

 (Ohagi)

[[20061019121604]]

 全く同じ内容のご質問ですね。同じ方ではないのかな？？？
 （やっちん）

ありがとうございます。
多い順にならないのは？どうしたらよいのでしょうか？

 すみません…(>_<)
 「数が多い順」を読み落としていました
 確認ですが、名前の隣にある数字は「行番号」で、
 「数が多い順」は「個数の多い順」でいいのですよね？

 Ａ列を削除する前にＣ列に、=COUNTIF(A:A,B1)　などとして個数を表示させ
 C列を範囲選択→コピー→形式を選択して貼り付け→値貼り付け
 Ａ列削除→Ｃ列基準で並べ替え→Ｃ列削除

 (Ohagi)

 あら・・・衝突・・・
 ちょっとだけ手順が違うので、乗せておきます。結果は一緒ですけど。
 カウント数がどこかに書いてないと並べ替えようがない。
 B2セルに=COUNTIF(A:A,A2)として、下方向へコピー
 それから、フィルタオプションの設定で重複なしのデータを抽出
 数の降順で並べ替え、数の列を削除。
 で、どうでしょう?　(Hatch)
	A	B
1	名前	数
2	青木	3
3	鈴木	2
4	吉村	1
5	青木	3
6	青木	3
7	鈴木	2

 ◆こんな方法もありますよ（空白対応していないので、汎用性は低いですが）
	A	B
1	青木	青木
2	鈴木	鈴木
3	吉村	吉村
4	青木	
5	青木	
6	鈴木

 B1=IF(ROW(A1)>SUMPRODUCT(1/COUNTIF($A$1:$A$6,$A$1:$A$6)),"",INDEX(A$1:A$6,MOD(LARGE(INDEX((MATCH(A$1:A$6
 ,A$1:A$6,0)=ROW($1:$6))*(COUNTIF(A$1:A$6,A$1:A$6)+(ROW($1:$6)/10^5)),),ROW(A1)),1)*10^5))
 ★下にコピー
(Maron)

 B列に書き出しで作成しています。
 (ROUGE)
'----
Sub test()
    Dim tbl, x, i As Long, dic As Object, ky
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet1")
        tbl = .Range("A1").CurrentRegion.Resize(, 1)
        For i = 1 To UBound(tbl, 1)
            If Not IsEmpty(tbl(i, 1)) Then
                If Not dic.exists(tbl(i, 1)) Then
                    dic.Add tbl(i, 1), Array(tbl(i, 1), 1)
                Else
                    x = dic(tbl(i, 1))
                    x(1) = x(1) + 1
                    dic(tbl(i, 1)) = x
                End If
            End If
        Next
        ReDim tbl(1 To dic.Count, 1 To 2)
        i = 0
        For Each ky In dic.keys
            i = i + 1
            tbl(i, 1) = dic(ky)(0)
            tbl(i, 2) = dic(ky)(1)
        Next
        DQS tbl, 2, 1, UBound(tbl, 1)
        .Range("B:B").ClearContents
        .Range("B1").Resize(UBound(tbl, 1), 1).Value = tbl
    End With
    Erase tbl: Set dic = Nothing
End Sub
Private Sub DQS(ByRef tbl, ky As Integer, ByVal tp As Long, ByVal bt As Long)
    Dim i As Long, j As Long, k As Integer, m As Long, buf
    i = tp: j = bt: m = (tbl(i, ky) + tbl(j, ky)) \ 2
    Do
        Do While tbl(i, ky) > m
            i = i + 1
        Loop
        Do While tbl(j, ky) < m
            j = j - 1
        Loop
        If i >= j Then Exit Do
        For k = LBound(tbl, 2) To UBound(tbl, 2)
            buf = tbl(i, k): tbl(i, k) = tbl(j, k): tbl(j, k) = buf
        Next
        i = i + 1: j = j - 1
    Loop
    If tp < i - 1 Then DQS tbl, ky, tp, i - 1
    If bt > j + 1 Then DQS tbl, ky, j + 1, bt
End Sub

みなさんありがとうございました！！
ばっちりわかりました。

コメント返信：

[ 一覧(最新更新順) ]

[[20061019164312]] 『ならべかえ』 現在 やりたい事 ページの最後に飛ぶ

[[20061019164312]]　『ならべかえ』現在やりたい事　ページの最後に飛ぶ