[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『並び替えの応用』（馬キチ）
以下のVBAコードを書く上で、アドバイスお願いします。
//表の説明
・1行目はタイトル行で、2行目以降がデータ行
・A列[ID]；IDナンバー（最大20万件までを想定）
・D列[N]；G列以降に入力されている番号（#1〜#18）の数
・G列以降；各番号のオッズ種（甲、乙、丙）別のオッズ値を示す
※番号順に甲、乙、丙のセットになっている
・番号の数は最大[18]だが、ID[ex2]のようにそれ未満の場合もある（以降の列のオッズ値は空欄）
//やりたいこと
・各IDで、甲種のオッズ値の昇順にそのオッズ値に該当する番号をシート[B]のB列、D列、F列…（飛び列）に出力する
・隣の列（C, E, G,…）には、「該当する番号の乙種のオッズ値」を出力する
・処理結果を配列に格納してから出力する（他での処理の都合上）
※今回は丙種については取り扱いません
シート[A]（表） A列 … D列 … G列 H列 I列 J列 K列 L列 M列 N列 O列 … BF列 BG列 BH列 1行目 ID … N … #1甲 #1乙 #1丙 #2甲 #2乙 #2丙 #3甲 #3乙 #3丙 … #18甲 #18乙 #18丙 2行目 ex1 … 18 … 51.5 6.5 9.1 3.1 4.2 6.5 1.6 1.2 2.1 … 2.5 3.1 4.2 3行目 ex2 … 3 … 38.6 6.1 7.9 4.6 1.9 2.7 15.7 4.8 6.6 （以降空欄） … … … … … … … … … … … … … … … … … シート[B]（結果） A列 B列 C列 D列 E列 F列 G列 … 1行目 ID 甲1 乙値 甲2 乙値 甲3 乙値 … 2行目 ex1 #3 1.2 #18 3.1 #2 4.2 … （甲の値の昇順が、1.6, 2.5, 3.1,…の場合） 3行目 ex2 #2 1.9 #3 4.8 #1 6.1
そもそもこれを一発で処理することが可能とも思えないレベルの者なので、
・飛びセルの昇順のしかた
・空欄の処理
・昇順した値から番号を得る方法
について「こういう方法があるよ」というアドバイスだけでも結構です。
よろしくお願いします。
＜ 使用 Excel：Excel2010、使用 OS：Windows10 ＞
少し詰めが甘い気がしますが、とりあえず提示例通りになると思います。 シート[A]（表） → Sheet1 シート[B]（結果）→ Sheet2 としています。
Sub test()
Dim dic As Object
Dim ts As Worksheet
Dim v, tmp, arr, odd
Dim i As Long, j As Long, k As Long, n As Long, m As Long
Set dic = CreateObject("Scripting.Dictionary")
v = Worksheets("Sheet1").Range("A1").CurrentRegion.Resize(, 60).Value
Worksheets("Sheet2").UsedRange.Clear
Set ts = Worksheets.Add
ReDim tmp(1 To 1, 1 To 6)
ReDim odd(1 To 37, 1 To 1)
odd(1, 1) = "ID"
For i = 2 To UBound(odd) Step 2
n = n + 1
odd(i, 1) = "甲" & n
odd(i + 1, 1) = "乙値"
Next
For i = 2 To UBound(v)
For j = 7 To 60 Step 3
n = 0
For k = 1 To 6 Step 2
tmp(1, k) = v(1, j + n)
tmp(1, k + 1) = v(i, j + n)
n = n + 1
Next
dic(v(1, j)) = tmp
Next
arr = dic.items
Call Sort_odds(ts, arr)
m = UBound(odd, 2) + 1
n = 0
ReDim Preserve odd(1 To UBound(odd), 1 To m)
odd(1, m) = v(i, 1)
For k = 2 To UBound(odd) Step 2
n = n + 1
If Not arr(n, 2) = "" Then
odd(k, m) = Replace(arr(n, 1), "甲", "")
odd(k + 1, m) = arr(n, 4)
End If
Next
Next
Worksheets("Sheet2").Range("A1").Resize(UBound(odd, 2), UBound(odd)) = Application.Transpose(odd)
Application.DisplayAlerts = False
ts.Delete
Application.DisplayAlerts = True
End Sub
Sub Sort_odds(ts As Worksheet, arr)
ts.Range("A1").Resize(UBound(arr) + 1, 6) = Application.Index(arr, 0, 0)
With ts.Sort
.SortFields.Clear
.SortFields.Add ts.Range("B1"), Order:=xlAscending
.SetRange ts.Range("A1").CurrentRegion
.Header = xlNo
.Apply
End With
arr = ts.Range("A1").CurrentRegion.Value
ts.UsedRange.Clear
End Sub
（外野フライ） 2023/11/02(木) 22:57:23
＞・飛びセルの昇順のしかた 飛びセルではなく、各IDの関連するデータをワークシートに書き出してソートしています。 サブルーチンでステップ実行してみてください。
＞・空欄の処理 具体的にどの空欄を指すのか分かりませんが、IF文で対応しました。
＞・昇順した値から番号を得る方法 これもどの部分か分かりませんが「#1甲」から｢#1」を取り出すということならReplaceを使いました。 （外野フライ） 2023/11/02(木) 23:03:23
実データで実行した結果、エラーなく出力されました。
結果とコードの確認（理解）は、時間ください。
取り急ぎお礼までとさせていただきます…
（馬キチ） 2023/11/02(木) 23:22:15
少しどころか大幅に詰めが甘く、穴だらけでした。 修正版を投稿します。
クイックソートは「エクセルの神髄」さんから丸ごとお借りしました。 https://excel-ubara.com/excelvba5/EXCELVBA229.html
Sub test3()
Dim v, arr(), odd
Dim i As Long, j As Long, k As Long, n As Long, m As Long
v = Worksheets("Sheet1").Range("A1").CurrentRegion.Resize(, 60).Value
ReDim odd(1 To UBound(v), 1 To 37)
odd(1, 1) = "ID"
For i = 2 To UBound(odd, 2) Step 2
n = n + 1
odd(1, i) = "甲" & n
odd(1, i + 1) = "乙値"
Next
For i = 2 To UBound(v)
n = 0
For j = 7 To 60 Step 3
m = 0
If Not v(i, j) = "" Then
n = n + 1
ReDim Preserve arr(1 To 6, 1 To n)
For k = 1 To 6 Step 2
arr(k, n) = v(1, j + m)
arr(k + 1, n) = v(i, j + m)
m = m + 1
Next
End If
Next
arr = Application.Transpose(arr)
Call クイックソート(arr, LBound(arr), UBound(arr), 2)
n = 0
For k = 1 To UBound(arr)
odd(i, 1) = v(i, 1)
n = n + 1
If Not arr(k, 2) = "" Then
odd(i, n + 1) = Replace(arr(k, 1), "甲", "")
odd(i, n + 2) = arr(k, 4)
n = n + 1
End If
Next
Erase arr
Next
With Worksheets("Sheet2")
.UsedRange.Clear
.Range("A1").Resize(UBound(odd), UBound(odd, 2)) = odd
End With
End Sub
Sub クイックソート(ByRef argAry As Variant, ByVal lngMin As Long, _
ByVal lngMax As Long, ByVal keyPos As Long)
Dim i As Long
Dim j As Long
Dim k As Long
Dim vBase As Variant
Dim vSwap As Variant
vBase = argAry(Int((lngMin + lngMax) / 2), keyPos)
i = lngMin
j = lngMax
Do
Do While argAry(i, keyPos) < vBase
i = i + 1
Loop
Do While argAry(j, keyPos) > vBase
j = j - 1
Loop
If i >= j Then Exit Do
For k = LBound(argAry, 2) To UBound(argAry, 2)
vSwap = argAry(i, k)
argAry(i, k) = argAry(j, k)
argAry(j, k) = vSwap
Next
i = i + 1
j = j - 1
Loop
If (lngMin < i - 1) Then
Call クイックソート(argAry, lngMin, i - 1, keyPos)
End If
If (lngMax > j + 1) Then
Call クイックソート(argAry, j + 1, lngMax, keyPos)
End If
End Sub
（外野フライ） 2023/11/03(金) 11:59:31
Power Query 適当に加工してみました。効率は考えていません。
let
ソース = Excel.CurrentWorkbook(){[Name="テーブル1"]}[Content],
ピボット解除された他の列 = Table.UnpivotOtherColumns(ソース, {"ID"}, "属性", "値"),
文字の移行による列の分割 = Table.SplitColumn(ピボット解除された他の列, "属性", Splitter.SplitTextByCharacterTransition({"0".."9"}, (c) => not List.Contains({"0".."9"}, c)), {"属性.1", "属性.2"}),
フィルターされた行 = Table.SelectRows(文字の移行による列の分割, each [属性.2] <> "丙"),
ピボットされた列 = Table.Pivot(フィルターされた行, List.Distinct(フィルターされた行[属性.2]), "属性.2", "値"),
グループ化された行 = Table.Group(ピボットされた列, {"ID"}, {{"tbl", each _, type table [ID=nullable text, 属性.1=nullable text, 甲=nullable number, 乙=nullable number]}}),
追加されたカスタム = Table.AddColumn(グループ化された行, "カスタム", each Table.Sort([tbl],{"甲"})),
追加されたカスタム1 = Table.AddColumn(追加されたカスタム, "カスタム.1", each Table.AddIndexColumn([カスタム],"index",1,1)),
削除された他の列 = Table.SelectColumns(追加されたカスタム1,{"カスタム.1"}),
#"展開された カスタム.1" = Table.ExpandTableColumn(削除された他の列, "カスタム.1", {"ID", "属性.1", "甲", "乙", "index"}, {"ID", "属性.1", "甲", "乙", "index"}),
ピボット解除された列 = Table.UnpivotOtherColumns(#"展開された カスタム.1", {"ID", "属性.1", "index"}, "属性", "値"),
追加された条件列 = Table.AddColumn(ピボット解除された列, "カスタム", each if [属性] = "甲" then [属性.1] else [値]),
挿入された結合列 = Table.AddColumn(追加された条件列, "結合済み", each Text.Combine({[属性], Text.From([index], "ja-JP")}, ""), type text),
並べ替えられた行 = Table.Sort(挿入された結合列,{{"index", Order.Ascending}}),
削除された列 = Table.RemoveColumns(並べ替えられた行,{"属性.1", "index", "属性", "値"}),
ピボットされた列1 = Table.Pivot(削除された列, List.Distinct(削除された列[結合済み]), "結合済み", "カスタム")
in
ピボットされた列1
（マナ） 2023/11/03(金) 13:29:40
> ソース = Excel.CurrentWorkbook(){[Name="テーブル1"]}[Content],
> ピボット解除された他の列 = Table.UnpivotOtherColumns(ソース, {"ID"}, "属性", "値"),
ピボット解除の前に、B〜F列を削除するステップが必要でした。 （マナ） 2023/11/03(金) 16:00:07
to マナさん
ご提案ありがとうございます。
Power Query…初見なのでザクっと調べてみましたが、ピボットテーブルに馴染めない身には
（ダウンロードが必要なことも含めて）ハードルが高い気がしました。
お許しください…（こういう手段もある、ということは気に留めておきます）
（馬キチ） 2023/11/03(金) 23:42:34
＞処理速度を考慮された改良でしょうか？ そうなります。検証用データを用意せず投稿したので・・・
＞クイックソートのところは未だ手つかずですが、甲オッズが同値の場合の扱いはどうなっているのでしょうか？ クイックソートのアルゴリズムは以下を参考にして下さい。 https://medium-company.com/%E3%82%AF%E3%82%A4%E3%83%83%E3%82%AF%E3%82%BD%E3%83%BC%E3%83%88/
場当たり対応で申し訳ありませんが、以下の部分を、
ReDim Preserve arr(1 To 6, 1 To n)
↓
ReDim Preserve arr(1 To 7, 1 To n) '変更
arr(7, n) = Format(v(i, j) * 10, "0000") & Format(Replace(Mid(v(1, j), 2), "甲", ""), "00") '追加
とし、
クイックソートの呼び出しを、
Call クイックソート(arr, LBound(arr), UBound(arr), 7) 'キーを7列目に変更
としていただいて試していただけますか。
甲オッズは単勝オッズだと思いますので桁数足りると思いますが、 1,000倍が有りうるなら"00000"として下さい。 （外野フライ） 2023/11/04(土) 06:57:50
時間なきため、結果報告のみで失礼します…
（馬キチ） 2023/11/04(土) 18:21:36
面白そうな題材だったので、暇つぶしにチャレンジしてみました。
ソートは「エクセルの神髄」さんの下記のページの挿入ソートを拝借しました。
1次元配列の並べ替え（バブルソート,挿入ソート,クイックソート）｜VBAサンプル集 https://excel-ubara.com/excelvba5/EXCELVBA228.html
並べ替えの件数は最大でも18件なので、クイックソートでなくても挿入ソートで十分高速なのでそれにしました。
Public Sub test()
Dim i As Long, j As Long, n As Long, c As Long
Dim 表(), 結果(), R()
表 = Worksheets("Sheet1").Range("A1").CurrentRegion.Value
ReDim 結果(1 To UBound(表), 1 To 37)
結果(1, 1) = "ID"
For j = 1 To 18
結果(1, j * 2) = "甲" & j
結果(1, j * 2 + 1) = "乙値"
Next
For i = 2 To UBound(表)
結果(i, 1) = 表(i, 1)
n = 表(i, 4)
ReDim R(1 To n)
For j = 1 To n
R(j) = (表(i, j * 3 + 4) * 1000) + j
Next
Call 挿入ソート(R)
For j = 1 To n
c = R(j) Mod 100
結果(i, j * 2) = "#" & c
結果(i, j * 2 + 1) = 表(i, c * 3 + 5)
Next
Next
With Worksheets("Sheet2")
.UsedRange.Clear
.Range("A1").Resize(UBound(結果), UBound(結果, 2)) = 結果
End With
End Sub
Sub 挿入ソート(ByRef argAry() As Variant)
Dim Low As Long
Dim Upp As Long
Low = LBound(argAry)
Upp = UBound(argAry)
Dim i As Long, j As Long
Dim vSwap As Variant
For i = Low + 1 To Upp
vSwap = argAry(i)
For j = i - 1 To Low Step -1
If argAry(j) > vSwap Then
argAry(j + 1) = argAry(j)
Else
Exit For
End If
Next
argAry(j + 1) = vSwap
Next
End Sub
（hatena） 2023/11/04(土) 20:46:42
丁度、ソートの学習中でして、これを機会に試みた両コードでの処理速度の3回計測結果です。
・クイックソート；24.00秒, 24.31秒, 23.62秒
・挿入ソート；6.77秒, 7.14秒, 6.84秒
ご紹介のサイトでは、クイックソートの方が圧倒的に早いはずなんですが…???
（何度か実行コードが逆になってないか確かめました）
まだ両コードを完全には理解できておらず、ソートの記事にいたってはアタマが痛くなってます。
こちらの何かの勘違いであれば、ご容赦ください。
※20万件の実データは入手に時間がかかるため、自作のほぼ同仕様のランダムデータ10万件での確認
※データはBH列まで全セル使用（空欄なし）
※両コードに下記の高速化設定を追記
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
※5年ほど前のi7パソコン使用
（馬キチ） 2023/11/05(日) 20:23:03
＞ご紹介のサイトでは、クイックソートの方が圧倒的に早いはずなんですが…??? サイトでは同じ配列をそれぞれのソートに渡して検証しています。 また、私の場合は2次元配列を、hatenaさんのコードでは1次元配列を渡しているのも相違点です。 多分ですけど、私のコードはソートに渡す配列を作る箇所で時間かかってるんだと思います。 （外野フライ） 2023/11/05(日) 21:36:42
今回のケースはいろいろ応用ができるので、理解に努めたいと思います。
これからもよろしくお願いします。
（馬キチ） 2023/11/05(日) 22:52:04
追記（ちょっと主題から外れますが…）
配列を同じにするために、hatenaさんコードの「Call 挿入ソート」部分のみを
クイックソートに置換して処理時間を測定してみた結果です。
クイックソート;7.39", 7.40", 7.30"
挿入ソート;7.08", 7.01", 7.00"
※クイックソートのコードはご紹介サイトのコピペです
※その他条件は、前掲と同じです
サイトに記載のような圧倒的な差はなかったです。（むしろ遅い？）
もちろんサイトとはデータやPC環境が異なるので一概には言えないですが、
データによっては、両ソートの処理時間には差が出ない時がある、との理解で
よろしいのでしょうか？
（馬キチ） 2023/11/06(月) 12:17:53
hatenaさんも書いてらっしゃいますが、 ソートしているのは最大18件ということを認識していますか？ データ総数が10万件だと言うことは分かっていますが、 並び替えているのは最大18件なので、目に見えた差は出ないと思います。 最大18件のソートを10万件繰り返した結果がその秒数であるわけで、 クイックソートの方が遅い、という結論には至らないと考えますが、、、 （外野フライ） 2023/11/06(月) 12:35:57
ハナさん、hatenaさん含め、貴重なお時間をいただきありがとうございました。
（馬キチ） 2023/11/06(月) 17:24:40
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.