Sortsub.bas
データの並び替え(ソート)は、案外使う場面が多いわけですが、設定が案外面倒で頭の中に入らない。

基本は、シート状の並び替えですが、シートとは、関係なく配列の並び替えも案外出てきます。

そこで並び替えのサブルーチンを作りました。

配列の並び替え

並び替えのサブルーチンで問題になるのが、配列の数です。

できれば、配列に入っているデータの数まで指定したくない。単に面倒というだけですが。

その場合、動的な配列を使用します。

動的な配列を使用する場合、配列の数を求める必要が出てきます。

その場合は、On Error を積極的に活用するのが一つの方法です。

配列の数を求める DimSub.bas

配列の数を求めるサブルーチン DimSub は、処理速度がかかってしまうのは仕方ない。

配列にデータをいれているところで数えればいいわけで、わざわざ数えさせるなって話です。

でも、可搬性や修正頻度を考慮しないといけないプログラムの場合、いちいち配列の定数を書き直したりするのは面倒ですし、バグのもとになりやすくなります。

配列の数を数えるサブルーチンのソースプログラム

Function Max(dimbox())<br /> 'dim dimBox(120),dim dimCnt,dimMax<br /> '<br /> "Dim Max<br /> 'dimMax = DimSub.Max(DelMarkWord_Val)<br /> '<br /> "Dim Clear<br /> 'dimCnt = DimSub.Clr(DelMarkWord_Val, "")<br /> '<br /> Dim i<br /> Dim errflg<br /> Dim keepi<br /> <br /> i = 0<br /> keepi = i<br /> Max = keepi<br /> errflg = 0<br /> Do While (1)<br /> DoEvents<br /> On Error GoTo rsm<br /> dimbox(i) = dimbox(i)<br /> On Error GoTo 0<br /> If errflg = 1 Then<br /> Max = keepi<br /> Exit Do<br /> End If<br /> keepi = i<br /> i = i + 1<br /> Loop<br /> Exit Function<br />rsm:<br /> errflg = 1<br /> Resume Next<br />End Function<br />

エラーが出るまでループを回してしまうという実に非効率な方法です。

ついでに配列のクリアもサブルーチン化しておきます。

配列をクリアするサブルーチン

配列をクリアするサブルーチンのソースプログラム

Function Clr(dimbox(), inival)<br /> 'dim dimBox(120),dim dimCnt,dimMax<br /> '<br /> "Dim Max<br /> 'dimMax = DimSub.Max(DelMarkWord_Val)<br /> '<br /> "Dim Clear<br /> 'dimCnt = DimSub.clr(DelMarkWord_Val, "")<br /> '<br /> <br /> Dim cntval, maxval<br /> maxval = Max(dimbox)<br /> For cntval = 0 To maxval<br /> dimbox(cntval) = inival<br /> Next cntval<br /> Clr = 0<br />End Function<br />

シートを並び替えるサブルーチン SortSub.bas

単一キーソート (データ行の継続が key cell の場合)

呼出し引数からわかるように、このサブルーチンは、ソートの最終行を指定しません。
つまり、サブルーチン内で算出してソートを行うようにしてあります。

このサブルーチンは、Key1Easy の名前の付け替えサブルーチンです。

使用例、
Call SortSub.Easy(ssht,1,"asm",1,1,20)<br />

単一キーソート (データ行の継続が key cell の場合)

使用例、
<br /> call sortsub.Key1Easy(ssht,1,"dsm",1,1,20)<br />

複数キーソート (データ行の継続が key cell の場合)

使用例、
'— 検索、ライバル、サイト数ソート —<br /> Dim keys(3) As Integer 'ソートキーセル番号<br /> Dim asmdsm(3) As String 'ソート方向<br /> Dim keycnt 'キー数<br /> Dim ssht 'ソート対象シート<br /> dim kp 'データの連続検査カラム<br /> Dim sr, sc, er, ec 'ソート対象セル範囲<br /> Dim rr 'ソート範囲検査行用ワーク<br /> <br /> Set ssht = ActiveSheet<br /> <br /> '————–<br /> '— SORT KEY<br /> '————–<br /> keycnt = 0<br /> '— 検索数<br /> keys(keycnt) = 4: asmdsm(keycnt) = "dsm": keycnt = keycnt + 1<br /> '— ライバル数<br /> keys(keycnt) = 18: asmdsm(keycnt) = "asm": keycnt = keycnt + 1<br /> '— サイト数<br /> keys(keycnt) = 3: asmdsm(keycnt) = "asm": keycnt = keycnt + 1<br /> '————–<br /> '— SORT RANGE<br /> '————–<br /> kp = 2 'continue check cpu,m<br /> sr = 4<br /> sc = 1<br /> ec = 30<br /> '————–<br /> '— SORT<br /> '————–<br /> Call SortSub.keysEasy(ssht, kp,keycnt, keys(), asmdsm(), sr, sc, ec)<br /> '————–<br />

複数キーソート (データ行の継続が key cell ではない場合)

使用例、
'— 検索、ライバル、サイト数ソート —<br /> Dim keys(3) As Integer 'ソートキーセル番号<br /> Dim asmdsm(3) As String 'ソート方向<br /> Dim keycnt 'キー数<br /> Dim ssht 'ソート対象シート<br /> Dim sr, sc, er, ec 'ソート対象セル範囲<br /> Dim rr 'ソート範囲検査行用ワーク<br /> Dim cc_pos 'データ継続検査セル<br /> <br /> Set ssht = ActiveSheet<br /> <br /> '————–<br /> '— SORT KEY<br /> '————–<br /> keycnt = 0<br /> '— 検索数<br /> keys(keycnt) = 4: asmdsm(keycnt) = "dsm": keycnt = keycnt + 1<br /> '— ライバル数<br /> keys(keycnt) = 18: asmdsm(keycnt) = "asm": keycnt = keycnt + 1<br /> '— サイト数<br /> keys(keycnt) = 3: asmdsm(keycnt) = "asm": keycnt = keycnt + 1<br /> '————–<br /> '— SORT RANGE<br /> '————–<br /> sr = 4<br /> sc = 1<br /> er = sr<br /> ec = 30<br /> cc_pos = 2<br /> '<br /> rr = sr<br /> Do While ssht.Cells(rr, cc_pos) <> ""<br /> er = rr<br /> rr = rr + 1<br /> Loop<br /> '————–<br /> '— SORT<br /> '————–<br /> Call SortSub.keys(ssht, keycnt, keys(), asmdsm(), sr, sc, er, ec)<br /> '————–<br />

シートのデータの並び替え SortSub.bas ダウンロード