ゲームの記録に順位を付ける事出来ますか？

質問

エクセル2000です。
以下の様なゲームの計時データがあります。これに順位を付けることできますか？
１行目の　A列＝年月日　B列＝タイム　C列＝車名　
そして　D列に、何番目に早いのか順位を振りたいのです。
２～5行目迄を行挿入の為の空欄にし（行選択して私登録のショートカットCtrl+Alt+↓キーで挿入）
6行目から12行目迄を逆順の年月日にし、プレイした「本日」の行に時計や車名を追加します。
その都度、D列にふられた順位が変動するようにしたいのです。
47'38"15 Bugatti Veyron 16.4
51'15"50 McLaren MP4-12C
48'30"43 Koenigsegg CCXR Edition
47'17"33 Pagani Zonda Cinque
50'04"85 Bugatti Veyron 16.4
50'01"70 McLaren MP4-12C
47'16"50 Pagani Zonda Cinque
50'02"17 Koenigsegg CCXR Edition
48'44"73 Koenigsegg CCXR Edition

回答No.4

tom04 · ベストアンサー

何度もごめんなさい。

投稿後に気づきました。
コード内の変数の宣言
＞i As Long,
は全く不要です。

コード内に「i」という変数は使っていませんので、
そのままでも問題ありませんが、目障りだったら消してください。m(_ _)m

お礼

＞i As Long,は全く不要です。
了解しました。10/20
閉じる様に要請が来て、もう2週間が過ぎたんですね。当方なんとかRange()使用と同一列（1～3行）に1位の記録を示してもカウントされない方法はないかと、本を読んだりネットで探したり膨大な時間を費やしましたが、見当たりませんでした。私見ではDim endRow As Long の宣言をその列の4行目以下からに出来れば？と無知な推測。この点を除けば快適なデータ管理となっております。
A1＝TODAY()、C1はIviza一周は1車のみの車名、G1に基本時計（2位のタイム）、I1～J1に文字列「平均時速」、K1にHawaiの2位のタイム
G2にIvizaの1位タイム、I2に=ROUND(115.1/(G2*24),3)
J2に=ROUND(198.2/(K2*24),3)、K2にHawaiの1位タイム、
A3～L3は日収賞金額・日時・登録名主・登録名1・登録名2・登録名3・距離112.1・空白・Iviza・Hawai・距離198.2　オワフ島・空白、M3～O3セル結合「昇順並替順位　車名　タイム」、
A4～L4 空セル、
A5は=SUM(C5:F5)-SUM(C6:F6)、B5はA1コピペし文字列に変換で10/20、A6～C6は82500＄・10/19・25474960＄、です。
ボタン1 押しで以下を実行。
Sub tdU2()
Dim endRow As Long
endRow = Cells(Rows.Count, "J").End(xlUp).Row
With Range(Cells(4, "H"), Cells(endRow, "H"))
.Formula = "=RANK(I4,I:I,2)"
.Value = .Value
End With
With Range(Cells(4, "L"), Cells(endRow, "L"))
.Formula = "=RANK(J4,J:J,2)"
.Value = .Value
End With
Range("K2") = WorksheetFunction.Min(Range(Cells(4, "J"), Cells(endRow, "J")))
Range("G2") = WorksheetFunction.Min(Range(Cells(4, "I"), Cells(endRow, "I")))
Range("K4:K165").Select
Selection.Copy
Range("N4:N165").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("J4:J165").Select
'ActiveWindow.ScrollRow = 1
Selection.Copy
Range("O4:O165").Select
ActiveSheet.Paste
'Range("L4").Select
'Application.CutCopyMode = False
Range("L4:L165").Select
'ActiveWindow.ScrollRow = 1
Selection.Copy
Range("M4:M165").Select
ActiveSheet.Paste
'Application.CutCopyMode = False
Range("M4:O165").Select
'ActiveWindow.ScrollRow = 1
Selection.Sort Key1:=Range("M1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
Range("L4").Select

End Sub

Private Sub CommandButton1_Click()
tdU2
End Sub

ボタン2 押しで以下を実行
Sub td()
Range("A4:L4").Select
Range("K4").Activate
Selection.Insert Shift:=xlDown
Range("B6").Select
Selection.Copy
Range("B5").Select
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
With Range("A6").Select
Selection.AutoFill Destination:=Range("A5:A6"), Type:=xlFillDefault
Range("A5:A6").Select
Range("A5").Select
End With

With Range("A1").Select
Selection.Copy
Range("B5").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("B5").Select
Application.CutCopyMode = False
Range("B5").Select
End With
Range("C5").Select
End Sub

Private Sub CommandButton2_Click()
td
End Sub
となっています。
D59、E70、F64 以下にはゲームの終了時の賞金があり
登録名主・登録名1・登録名2・登録名3・のどれかを遊んだ時、多分SUMIF()で計算するのでしょうが、各列の一番近い列行（セル）の見つけ方が解らないので、主列のみで遊んでいます。未完了のエベントのある登録名1・登録名2・登録名3 はお休みです。
A5を=+SUM(C5:F5)-SUM(C6:F6)にするのに下からオートフィルしてますが、それに影響があるかどうか不明です。
長文ごめんなさい。ありがとうございました
兎にも角にも、ひたすら、感謝申し上げます。

回答No.3

tom04

続けてお邪魔します。

＞同タイムは同じ順位がふられ次が欠番になる事。
の件に関して・・・
RANK関数を使用していましたので、同順の場合はそのような結果となります。
ご希望としては同順位はつけたくない！というコトのようですので、
↓のコードに変更してみてください。

Sub Sample3()
Dim i As Long, endRow As Long
endRow = Cells(Rows.Count, "G").End(xlUp).Row
Range("G2:H2").ClearContents '←G2・H2を消去
'以下同順位の場合は上の行が上位に！（ランク関数は使用しない）
With Range(Cells(3, "J"), Cells(endRow, "J"))
.Formula = "=COUNTIF(G:G,""<""&G3)+COUNTIF(G$3:G3,G3)"
.Value = .Value
End With
With Range(Cells(3, "K"), Cells(endRow, "K"))
.Formula = "=COUNTIF(H:H,""<""&H3)+COUNTIF(H$3:H3,H3)"
.Value = .Value
End With
Range("G2") = WorksheetFunction.Min(Range(Cells(3, "G"), Cells(endRow, "G")))
Range("H2") = WorksheetFunction.Min(Range(Cells(3, "H"), Cells(endRow, "H")))
End Sub

※　同タイムの場合は上側の行が上位に表示されます。

＞さらに、３１番迄しか順位付けが無いのに９０位などがある。
に関しては判りかねますので、スルーさせてください。m(_ _)m

お礼

3/14 myページを見てびっくり。お礼してない回答が125件あります。ですって? サーバーが逝かれた?
遅ればせながら、
ご回答、ありがとうございました。

補足

お邪魔なんてとんでもありません。
感謝のあまり涙ものです。
＞スルーさせてください
は、回答２のお礼に書きましたが、H列のデータ最下位（H157）と同じG157を空白とせずG列の最下位（G31）のデータをG157にコピペすると解消しました。それまでは順位がK31迄しか表示されませんでした。
また、同お礼に書いた
＞Range("G2")⇒Range("I2")だとJ K列削除だけでマクロ実行でI2の値が変更されますのでこちらをとります。
ですが、J K列も削除しなくても書き換わる様になって、原因特定不明です。
サンプル3 を頂き、それにしてみたら、何故かK列の順位1位が2個できます。H2の表示セルをI2にしても変わりません。
したがってサンプル２の「同順位表示＆次を飛ばし」の方が良い。データ空白行をゼロ表示ではなく＃N/A の方が便利な事もあり（確認行為＝K列をL列にコピペ並び替え昇順でゼロが邪魔などあり）
サンプル２を使います。ネット検索してボタン登録もでき、なんとボタンはセル上表示じゃん。で、最小にしてI列の1行めに置き、便利に使えます。
ありがとうございました。心底より感謝申し上げます。

回答No.2

tom04

No.1です。

＞列選択し書式でセルをユーザー定義のmm:ss.0 を設定して、ダブルをピリオド、シングルをコロンに全置き換しました。

とありますので、データそのものが数値として判断されます。
すなわちデータそのままがRANK関数で使用できますので、操作としてはかなり簡単になりました。

＞３行目からがデータとなります
前回は2行目以降にデータがある！という前提のコードでしたので、
もう一度コードを載せてみます。

尚、G2・H2セルの表示形式もユーザー定義から
mm:ss.00
としておいてください。

Sub Sample2()
Dim endRow As Long
endRow = Cells(Rows.Count, "G").End(xlUp).Row
With Range(Cells(3, "J"), Cells(endRow, "J"))
.Formula = "=RANK(G3,G:G,2)"
.Value = .Value
End With
With Range(Cells(3, "K"), Cells(endRow, "K"))
.Formula = "=RANK(H3,H:H,2)"
.Value = .Value
End With
Range("G2") = WorksheetFunction.Min(Range(Cells(3, "G"), Cells(endRow, "G")))
Range("H2") = WorksheetFunction.Min(Range(Cells(3, "H"), Cells(endRow, "H")))
End Sub

※　最終行をどの列で取得するか迷ったのですが、
とりあえずG列で最終行を取得するようにしています。m(_ _)m

お礼

出来ました。心よりの感謝です。
初めうまく行った後、２度めのデータ追加で２番手が無くなりました。知識なく更に数年マクロを運用していなかったので、脇道に迷い込み、何度も、使いふるした温存エクセルのコピーを使い試行錯誤。
まず分かったのは同タイムは同じ順位がふられ次が欠番になる事。
さらに、３１番迄しか順位付けが無いのに９０位などがある。
TDU2と言うレーシングゲームの
G列＝イビザ島一周タイムトライアル
H列＝オワフ島一周タイムトライアル　なのですが、
イビザ島は低ランクの物で車はSubaru impreza WRX STI A6 のみですから、エクセルに記録を始めたのはずっと後で、G31迄しかデータがありません。そのセルを最下位のG157に移動するとK列の順位も全て表示するようになり解決。
つぎに「2番手」が欠番になる点はH2も見ていてなるのかとも。
で新しいデータ入れの際J K列削除だけでなくG2やH2も削除すれば解決しますが、Range("G2")⇒Range("I2")だとJ K列削除だけでマクロ実行でI2の値が変更されますのでこちらをとります。たぶん構文の何処かを変えれば良いのかも？
現時点でも、たいへん助かっております。
ありがとうございました。
追伸
読者のタメと言うか、補足のコードに欠落がありました。
Sub 和DelUP()
Selection.Delete Shift:=xlUp
End Sub
Sub 和DelLeft()
Selection.Delete Shift:=xlToLeft
End Sub
Sub 和InsRight()
Selection.Insert Shift:=xlToRight
End Sub
Sub 和InsDown()
Selection.Insert Shift:=xlDown
End Sub
これがないと便利なセルの増減はだめかと、、、、、、。
脱線ごめんなさい。

回答No.1

tom04

こんばんは！

＞２～5行目迄を行挿入の為の空欄にし（行選択して私登録のショートカットCtrl+Alt+↓キーで挿入）
というコトはあらかじめ数式を入れていてもまったく無意味になってしまいますね！

そこでVBAになってしまいますが、一例です。
B列のタイムは質問通りの入力方法なのでしょうか？
本来であれば、0:47:17.33
のような入力方法が好ましいのですが・・・

今回は質問通りの入力となっているとします（分がシングルクォーテーション・秒がダブルクォーテーション）

画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim endRow As Long
endRow = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
Range("A:A").Insert
With Range(Cells(2, "A"), Cells(endRow, "A"))
.Formula = "=(0&"":""&SUBSTITUTE(SUBSTITUTE(C2,CHAR(34),"".""),""'"","":""))*1"
.Value = .Value
End With
With Range(Cells(2, "E"), Cells(endRow, "E"))
.Formula = "=RANK(A2,A:A,2)"
.Value = .Value
End With
Range("A:A").Delete
Application.ScreenUpdating = True
End Sub 'この行まで

※　タイムは質問通り、時間の部分はなくて　○分○秒○○　とします。
※　データ変更があるたびにマクロを実行する必要があります。m(_ _)m

お礼

2019/3/14
myページを見てびっくり。お礼してない回答が125件あります。ですって?
遅ればせながら、
ご回答、ありがとうございました。

補足

ご回答いただき感謝申し上げます。
新しくエクセルを開き実験した所、空白のD２とD3 に１番がふられタイムデータのある行のD列には３番以降が表示されました。空白行を削除すれば正しく表示されます。
ま、上詰めにして、新しいデータを入れる際に１行だけ選択して1行追加と日にちを入れれば済むのですが、、、、。
もう何年もタイピングは練習してないので、アルファベット以外はキーボードを見ないと入れられないのでコロンとピリオドに変えました。列選択し書式でセルをユーザー定義のmm:ss.0 を設定して、ダブルをピリオド、シングルをコロンに全置き換しました。それで甘えなのですが以下の条件で新しく作って頂けると幸いです。
タイム列はGとH、
G列の順位はJ列に表示、
H列の順位はK列に、
更にG2とH２に過去最高タイム表示。
３行目からがデータとなります。
新しいタイムトライアルの記録は３行目を選択し[Ctrl+Alt+↓キー]します。これは１０年ほど前ここで教わった「オートオープン」です。ちなみに、、、、
Sub Auto_Open()
Application.OnKey "^%{UP}", "和DelUp"
Application.OnKey "^%{DOWN}", "和InsDown"
Application.OnKey "^%{LEFT}", "和DelLeft"
Application.OnKey "^%{RIGHT}", "和InsRight"

Application.OnKey "^%{z}", "色消すz"
Application.OnKey "^%{H}", "青色H"
Application.OnKey "^%{h}", "空色h"
End Sub
Sub 色消すz()
Selection.Interior.ColorIndex = xlNone
End Sub

Sub 青色H()
With Selection.Interior
.ColorIndex = 41
.Pattern = xlSolid
End With
End Sub

Sub 空色h()
With Selection.Interior
.ColorIndex = 8
.Pattern = xlSolid
End With
End Sub
など意味理解なくコピペして便利に使っております。感謝。