エクセルマクロ(大量データでのソート)

質問

以下のような表形式(300列×500行)のデータをソートしなくてはならず、エクセルマクロでやろうと思うのですが、
初心者のためできず困っています。助けて頂けませんでしょうか。
アクセスなどほかのアプリで簡単にできるようであれば、別の方法でも構いません。

[入力例]値なし=0

　　　　X1　　X2　　X3　　X4　…　X299　　X300
　　　----------------------------------------
Y1　|　　3　　101　　　　89　　　　　　　　　2
Y2　|　　　　　　　143　　9
Y3　|
Y4　|　　　　　　　　　　　　　　　　5　　　1
：　|
Y499|　　5　　2　　10
Y500|　　　　　　　　　　10

[出力例]
Yxについてそれぞれ上位10位までの結果を出力。括弧内に値を出力。
※値が同じものについては順不問。

Y1　　X200(120)　　X2(101)　　X145(83)　　X99(20)　…　X65(2)　　X1(3)
Y2　　X3(143)　　　X4(9)　　　X1(0)　　　　X2(0)　…　　X9(0)　　X10(0)
：
Y500　　X4(10)　　X31(8)　　　X11(7)　　　X31(7)　…　X1(0)　　　X2(0)

宜しくお願いします。

回答No.2

mt2008 · ベストアンサー

単純に上位10個までで並び替えるのだけでしたら簡単ですが、Xnn(mm)の様な文字列を作って表示となると面倒ですね。
Excelでやる場合を説明しますが、まず、Excelで行う場合、300列を扱うためには、Excel2007が必須になります。
その上で、やり方は色々とあると思いますが、私でしたらソートをExcelシートにやらせる為に、次の様な処理のマクロを組みます。

1.1行目の列の項目名（X1～X300)と、対象行の値を作業用のシートに行列を入れ替えてコピー。
2.ワーク用シートで項目名と値を並べ替え（値を降順で）
3.貼り付け用のデータ（10位までの「Xnn(mm)」と言う文字列)を作って結果用のシートに貼り付け
4.１に戻る

以下の例では、Sheet1を元データ用、Sheet2を結果用、Sheet3を作業用にしています。
また、予め、Sheet3のC1セルに　=A1&"("&B1&")"　と入れてC10までコピーしておいてください。

Sub Sample()
　Dim nLoop As Long
　nLoop = 2
　Application.ScreenUpdating = False '画面の更新停止

　　Do While (True)
　　　If Sheets("Sheet1").Cells(nLoop, 1) = "" Then Exit Do　'A列が空なら終了

　　　'作業シートの掃除
　　　Sheets("Sheet3").Select
　　　Columns("A:B").Select
　　　Application.CutCopyMode = False
　　　Selection.ClearContents

　　　'列見出しのコピー
　　　Sheets("Sheet1").Select
　　　Range(Cells(1, 2), Cells(1, 301)).Select
　　　Selection.Copy
　　　Sheets("Sheet3").Select
　　　Range("A1").Select
　　　'行列入れ替え貼り付け
　　　Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True

　　　'データのコピー
　　　Sheets("Sheet1").Select
　　　Range(Cells(nLoop, 2), Cells(nLoop, 301)).Select
　　　Selection.Copy
　　　Sheets("Sheet3").Select
　　　Range("B1").Select
　　　'数値として扱わせるために、値のみを加算で行列入れ替え貼り付け
　　　Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, Transpose:=True

　　　'データのソート
　　　Columns("A:B").Select
　　　Selection.Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlGuess

　　　'10位までの情報コピーして結果用シートに貼り付け
　　　Range("C1:C10").Select
　　　Selection.Copy
　　　Sheets("Sheet2").Select
　　　Cells(nLoop, 2).Select
　　　Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True

　　　nLoop = nLoop + 1
　　Loop
　Application.CutCopyMode = False
　Application.ScreenUpdating = Truealse　'画面の更新再開
End Sub

お礼

mt2008さん
ありがとうございます。素人が故、下らないところで
四苦八苦しましたが、おかげさまで無事できました！

回答No.1

nfushi

セルのB1にx1、A2にy1があると仮定しますと最終行y500はA501となります。

1行下を空行にして、その1行下から
y1,=OFFSET(A2,-1,MATCH(LARGE(B2:D2,1),B2:D2,0)) &"("& OFFSET(A2,0,MATCH(LARGE(B2:D2,1),B2:D2,0)) &")",=OFFSET(A2,-1,MATCH(LARGE(B2:D2,2),B2:D2,0)) &"("& OFFSET(A2,0,MATCH(LARGE(B2:D2,2),B2:D2,0)) &")",・・・・・,=OFFSET(A2,-1,MATCH(LARGE(B2:D2,10),B2:D2,0)) &"("& OFFSET(A2,0,MATCH(LARGE(B2:D2,10),B2:D2,0)) &")"
y2,=OFFSET(A2,-2,MATCH(LARGE(B2:D2,1),B2:D2,0)) &"("& OFFSET(A2,0,MATCH(LARGE(B2:D2,1),B2:D2,0)) &")",=OFFSET(A2,-2,MATCH(LARGE(B2:D2,2),B2:D2,0)) &"("& OFFSET(A2,0,MATCH(LARGE(B2:D2,2),B2:D2,0)) &")",・・・・・,=OFFSET(A2,-2,MATCH(LARGE(B2:D2,10),B2:D2,0)) &"("& OFFSET(A2,0,MATCH(LARGE(B2:D2,10),B2:D2,0)) &")"
・・・

のように入力下さい。

お礼

nfushiさん
ありがとうございます。ご回答いただいたもので、
できるのかとおもうのですが、いろいろ試行錯誤したのですが、
当方のスキル不足ために上手くできませんでした。
即答頂いたにも関わらず申し訳ございませんでした。
上記のとおり、解決いたしましたので、Closeさせて頂きます。