Excel VBAについてご質問させてください。 素人でVBAはまだまだ勉強中でよくわかりません。 質問に対しての質問や批判は必ずくるのでわざわざ回答されなくて大丈夫です。

画像

Excel | Visual Basic191閲覧xmlns="http://www.w3.org/2000/svg">250

1人が共感しています

ベストアンサー

1
画像

1人がナイス!しています

遅くなりました。 うまくいきました。 ありがとうございます。 これでも十分にいけるのですが、赤い数字の回数が同一の時、 赤い数字の若い順ではなくて隣の順位の若い順に変更できますでしょうか? 図々しいお願いで大変申し訳ございません。 よろしくお願いいたします。

ThanksImg質問者からのお礼コメント

ご丁寧な回答ありがとうございました。 本当に助かりました。 ほかの皆さんも参考にさせていただいています。 感謝いたします。

お礼日時:6/29 22:35

その他の回答(2件)

2

確かバブルソートとか言っていたはずので並べ替えます。 余り高速ではないけどお手軽、というメリットがあり、今回のような表にはいいと思います。 ※K2:T11以外は表ができているものとします。 Sub test() Dim i As Long, j As Long, k As Long Dim r As Long, s As Long Dim buf1 As Long, buf2 As Long, Num, Rnd For k = 4 To 8 Num = Range("A2:A16").Value Rnd = Range(Cells(2, k), Cells(16, k)).Value For j = 2 To 15 For i = 15 To j Step -1 If Rnd(i, 1) > Rnd(i - 1, 1) Then buf1 = Rnd(i - 1, 1) buf2 = Num(i - 1, 1) Rnd(i - 1, 1) = Rnd(i, 1) Num(i - 1, 1) = Num(i, 1) Rnd(i, 1) = buf1 Num(i, 1) = buf2 End If Next Next r = r + 2 For j = 11 To 20 Step 2 s = s + 1 Cells(r, j) = Num(s, 1) Cells(r + 1, j) = Rnd(s, 1) Next s = 0 Next End Sub

2人がナイス!しています

並べ替えてる配列変数はA列がNum、 1列ごとにRndを降順に並び変えています。 ワースト5は配列の後ろから取り出せばいいですね。 つまり sを15からデクリメントすればいいわけです。

2

>また、この逆のワースト5も出したいです。 どこにどう出力するのか説明されておらず、質問も受け付けないとのことなので、無視しました。後からリクエストは受け付けません。自力でどうぞ。 Option Explicit Const ID範囲$ = "A2:A16" Const 回数範囲$ = "C2:C16" Const データ範囲$ = "D2:H16" Const 転記先起点行& = 2 Const 転記先起点列& = 11 Const 転記先列間隔& = 2 Dim RS As Object Dim ID, Count, Data Sub Example() ID = Range(ID範囲) Count = Range(回数範囲) Data = Range(データ範囲) Call initADODBRS Call initADODBFields Call openRS Call setDataToRS Call setDataToWS Call closeRS End Sub Sub initADODBRS() Set RS = CreateObject("ADODB.Recordset") RS.cursortype = 1 'adOpenKeyset RS.CursorLocation = 3 'adUseClient RS.lockType = 2 'adLockPessimistic End Sub Sub initADODBFields() Dim i As Long RS.Fields.Append "ID", 3 RS.Fields.Append "count", 3 For i = LBound(Data, 2) To UBound(Data, 2) RS.Fields.Append "score" & i, 3 'adInteger Next End Sub Sub openRS() RS.Open End Sub Sub closeRS() RS.Close End Sub Sub setDataToRS() Dim r As Long, c As Long For r = LBound(Data, 1) To UBound(Data, 1) RS.addNew RS.Fields("ID").Value = ID(r, 1) RS.Fields("count").Value = Count(r, 1) For c = 2 To RS.Fields.Count - 1 RS.Fields(c).Value = Data(r, c - 1) Next RS.Update RS.movenext Next End Sub Sub setDataToWS() Dim s As Long, r As Long For s = LBound(Data, 2) To UBound(Data, 2) Call sortRS(s) Call printRS(s, 転記先起点行 + r) r = r + 2 Next End Sub Sub sortRS(score As Long) RS.Sort = "score" & score & " DESC, count DESC" RS.moveFirst End Sub Sub printRS(score As Long, r As Long) Dim top As Long, c As Long Do While RS.EOF = False Cells(r, 転記先起点列 + c) = RS.Fields("ID").Value Cells(r + 1, 転記先起点列 + c) = RS.Fields("score" & score).Value top = top + 1 If top >= UBound(Data, 2) Then Exit Do c = c + 転記先列間隔 RS.movenext Loop End Sub

画像

2人がナイス!しています