Excel VBA: オートフィルターの処理

質問

いつもお世話になります。
オートフィルターの処理をマクロでやれという指令がきました。具体的に言うと、

＃｜キー
－＋－
１｜Ａ＜＝カーソル位置
２｜Ｂ
３｜Ａ
４｜Ａ
５｜Ｃ
６｜Ａ
７｜Ｂ

のようなシートがあった場合、ツールバーのボタンをクリックするたびに

＃｜キー
－＋－
１｜Ａ＜＝カーソル位置
＝＝＝＝＝隠れ
３｜Ａ
４｜Ａ
＝＝＝＝＝隠れ
６｜Ａ

★

＃｜キー
－＋－
＝＝＝＝＝隠れ
２｜Ｂ＜＝カーソル位置
＝＝＝＝＝隠れ
７｜Ｂ

★

＃｜キー
－＋－
＝＝＝＝＝隠れ
５｜Ｃ＜＝カーソル位置
＝＝＝＝＝隠れ

のように遷移しなさいという問題です。

やっかいなのは、ボタンを押す間に別の作業が入る（同じマクロの連続実行の中で遷移させることができない。Excelを終了して（フィルター状態は保存）途中からやることもあることです。

最初は
（１）フィルターがないときはカーソル位置のデータでフィルターする
（２）フィルターがあるときは
（（１））フィルターを解除する
（（２））カーソル位置のキーを覚えておく
（（３））下になめていって、覚えているのと違うキーが出てきたらその値でフィルターする
みたいにしていたのですが、カーソル位置を常に見つかったのの中で先頭に戻しなさい、と言われたので、使えなくなってしまいました。（今ここです）

キーの値のバリエーションを配列に入れて、言わば自前でフィルターを作ってやればいいのかもしれませんが、マクロを実行するたびに全データをスキャンすることになるので、遅くなると思います。

手動で「データ」＝＞「オートフィルタ」をやったときのフィルターの一覧を取り出して配列に入れることができれば一番いいと思うのですが、その方法が見出せませんでした。

ということで、
質問１：「データ」＝＞「オートフィルタ」をやったときのフィルターの一覧を取り出して配列に入れることはできるでしょうか
質問２：上の題意でどのようなプログラムが考えられるでしょうか

次は、同じ問題の発展形なのですが、

　｜キ｜キ
　｜イ｜イ
＃｜１｜２
－＋－－－－
１｜Ａ｜あ＜＝カーソル位置
２｜Ｂ｜あ
３｜Ａ｜あ
４｜Ａ｜い
５｜Ｃ｜い
６｜Ａ｜い
７｜Ｂ｜う

のようになったとき、ボタンを押すたびに、

　｜キ｜キ
　｜イ｜イ
＃｜１｜２
－＋－－－－
１｜Ａ｜あ＜＝カーソル位置
＝＝＝＝＝隠れ
３｜Ａ｜あ
＝＝＝＝＝隠れ

★

　｜キ｜キ
　｜イ｜イ
＃｜１｜２
－＋－－－－
＝＝＝＝＝隠れ
２｜Ｂ｜あ＜＝カーソル位置
＝＝＝＝＝隠れ

★

　｜キ｜キ
　｜イ｜イ
＃｜１｜２
－＋－－－－
＝＝＝＝＝隠れ
４｜Ａ｜い＜＝カーソル位置
＝＝＝＝＝隠れ
６｜Ａ｜い
＝＝＝＝＝隠れ

のように遷移しろというものですが、これもエレガントな書き方があるでしょうか。
一応キー１、キー２の値を配列にとって、キー１の個々の値でフィルターして、次にキー２の個々の値でフィルターする、ただし、キー１の値によってはありえないキー２の値でフィルターしてしまうかもしれないので気を付ける、というやり方は思いつくのですが・・・。

以上、よろしくお願いします。

回答No.8

kenpon24 · ベストアンサー

やっとまとまった時間が取れたのでよくよく見返してみると・・・間違ってますね。
qSortの複数列入れ替えの対応も間違ってますし、
実験してみたところend-uさんの言う通り、複数列をkeyにするとクイックソートの不安定な特性から正しく並べ替えできないことになりました。

不安定なソートとは
13 A
15 A
17 B
15 B
という並びに大して1列目をキーにしてソートすると
13 A
15 B
15 A
17 B
という並びになってしまうことがある。
つまり、語弊があるかもしれないけどキー以外は考慮できないソートになります。
安定版のクイックソートアルゴリズムもあるようなのですが、ちょっと面倒な感じです。

あたかも問題なくできるような書き方をして申し訳ありませんでした。m(_ _)m

並び順の変わらない安定なソートとして有名なものにマージソートというものがあります。マージソートを作ってみましたので、グローバルにリストを持たせるサンプルを書いておきます。
複数列を同時に並び変えたかったのでちょっとイレギュラーですがJAG配列ってのを使ってみました。
リストを作る上ではend-uさんの使っているDictionaryコレクションの方が楽かもしれませんが、こんな方法もあるよってことでよろしくお願いします。

Dictionaryコレクションについて-重複しないリストを作る
http://officetanaka.net/excel/vba/tips/tips80.htm

'半角空白２個を全角空白１個に置き換えてインデントを表現しています。
Option Explicit
Const keyCol As Long = 3 'キーのカラム位置
Public Arrs() As Variant

Sub test3() '起動時に読み込むにはSub Auto_Open()とするのがよい
Dim Temp As Variant
Dim i As Long
Dim a As Variant

Erase Arrs

For i = 2 To Range("A65536").End(xlUp).Row
'1行分のデータを取得する
Temp = Range("A" & i & ":B" & i)
ReDim Preserve Arrs(i - 1)
'配列に配列を入れる (JAG配列)
Arrs(i - 1) = Temp
Next i

Call mySort(Arrs, 2, 1)

' 'テスト
' '配列領域の確保
' a = Range("I" & 2 & ":J" & Range("A65536").End(xlUp).Row)
'
' For i = 1 To UBound(Arrs)
' 'JAG配列からデータを取り出す
' a(i, 1) = Arrs(i)(1, 1)
' a(i, 2) = Arrs(i)(1, 2)
' Next i
' 'シートに貼り付ける
' Range("I" & 2 & ":J" & Range("A65536").End(xlUp).Row) = a

End Sub
'第3優先まで対応のソート関数 key2とkey3はデフォルトの引数で0を指定しておく。
'最低限、第1優先は必要
Private Sub mySort(ByRef Arr, key1 As Integer, Optional key2 As Integer = 0, Optional key3 As Integer = 0)

Dim iMax As Long
Dim iMin As Long
iMin = LBound(Arr)
iMax = UBound(Arr)

'優先度の低い項目からソートしていく
If key3 <> 0 Then
Call mergeSort(Arr, iMin, iMax, key3)
End If

If key2 <> 0 Then
Call mergeSort(Arr, iMin, iMax, key2)
End If

Call mergeSort(Arr, iMin, iMax, key1)

End Sub

' マージソート
' 既にソート済みの2つの配列を併合して新しい配列を
'生成することで、データのソートを行います。
Private Sub mergeSort(ByRef Arr As Variant, ByVal iMin As Long, iMax As Long, key As Integer)
Dim iCent1 As Long
Dim iCent2 As Long
Dim Arr1() As Variant
Dim Arr2() As Variant
Dim i As Long

If iMax - iMin <= 1 Then
Exit Sub
End If

'Arrを半分に分割したArr1, Arr2を作成する
iCent1 = (iMax - iMin) / 2
iCent2 = (iMax - iMin) - iCent1

ReDim Arr1(iCent1)
ReDim Arr2(iCent2)

For i = 1 To iCent1
Arr1(i) = Arr(i)
Next i

For i = 1 To iCent2
Arr2(i) = Arr(iCent1 + i)
Next i

'再帰的に呼んでどんどん細かくしていく
Call mergeSort(Arr1, LBound(Arr1), UBound(Arr1), key)
Call mergeSort(Arr2, LBound(Arr2), UBound(Arr2), key)
'再帰の帰り道でソートしながら結合していく
Call merge(Arr1, Arr2, Arr, key)

Erase Arr1
Erase Arr2
End Sub

'マージ
'2つの配列Arr1とArr2を併合してArryを作ります
' Arr1 Arr2 Arr
' 15 17 から 15
' 18 17 を作るイメージ
' 18
'JAG配列を使っているので、1行数列分の配列を丸ごと格納している
Sub merge(ByRef Arr1 As Variant, ByRef Arr2 As Variant, ByRef Arr As Variant, key As Integer)
Dim i As Long
Dim j As Long

i = 1
j = 1
While i <= UBound(Arr1) Or j <= UBound(Arr2)
'Arr2の添え字がArr2のサイズを超えているときはArrにArr1を入れる
' Arr1 Arr2 Arr
' 15
' 15 17 17
' 18 --------->18
'
If j > UBound(Arr2) Then
Arr(i + j - 1) = Arr1(i)
i = i + 1
GoTo NEXT_Arr
End If

'上記の逆パターン
If i > UBound(Arr1) Then
Arr(i + j - 1) = Arr2(j)
j = j + 1
GoTo NEXT_Arr
End If

'比較して小さい方をArrに入れる (JAG配列にアクセスしてkeyで比較する)
' Arr1 Arr2
' A ア
' A イ <-> B ア key2で比較する場合、Arr2を小さいと見る
'
If Arr1(i)(1, key) <= Arr2(j)(1, key) Then
Arr(i + j - 1) = Arr1(i)
i = i + 1
Else
Arr(i + j - 1) = Arr2(j)
j = j + 1
End If

NEXT_Arr:

Wend

End Sub

お礼

kenpon24さん、本当にありがとうございました。
そうなんです、クイックソートは安定ソートじゃないのでキーが２個以上の場合は使わない方がいいんですね。
今回はオンメモリ＋Dictionaryコレクション＋キーはクイックソートでとりあえずの完成版となりました。
上のend_uさんへのお礼をご笑覧ください。
まだまだ汚いと思いますが、短くはなっています。
金曜日の午後と今朝と、通産８時間ぐらいの作業ですが、今回だけでなくすごくいろいろ教わってよかったです。
本当にみなさんありがとうございました。

回答No.7

end-u

>フト、作業シートは今開いているシートの右側でやればいいかもしれないとも思いました。
いえ、無ければ追加すれば良いだけの話です。

Sub test()
　　Dim ws1 As Worksheet
　　Dim ws2 As Worksheet

　　With ThisWorkbook
　　　　Set ws1 = .ActiveSheet
　　　　On Error Resume Next
　　　　Set ws2 = .Sheets("unique")
　　　　On Error GoTo 0
　　　　If ws2 Is Nothing Then
　　　　　　Set ws2 = .Sheets.Add
　　　　　　ws2.Name = "unique"
　　　　　　'ws2.Visible = xlSheetVeryHidden
　　　　End If
　　End With

　　ws2.UsedRange.ClearContents
　　ws1.Cells(1).CurrentRegion.Resize(, 2) _
　　　　　　.AdvancedFilter xlFilterCopy, _
　　　　　　　　　　　　　　CopyToRange:=ws2.Cells(2), _
　　　　　　　　　　　　　　Unique:=True

　　With ws2
　　　　.Cells(2).CurrentRegion.Sort Key1:=.Cells(3), Order1:=xlAscending, _
　　　　　　　　　　　　　　　　　　 Key2:=.Cells(2), Order2:=xlAscending, _
　　　　　　　　　　　　　　　　　　 Header:=xlYes, OrderCustom:=1, _
　　　　　　　　　　　　　　　　　　 MatchCase:=False, Orientation:=xlTopToBottom, _
　　　　　　　　　　　　　　　　　　 SortMethod:=xlStroke
　　　　.Cells(1).Value = ws1.Name
　　End With

　　Set ws1 = Nothing
　　Set ws2 = Nothing
End Sub
...など。

>複数のシートを途中で作業中断して切り替えたり、人にシートを渡したりすることさえありうるので、採用を断念しました。
マクロはどうやって渡しますか？シートモジュール？
マクロブックやアドインで渡すならそのBookに作業シートを設定すればいいですよね？
...とはいえ、少量のデータなら手軽に配列ソートしたいというニーズがある事も理解できなくはないです。

ただ、クイックソートでは連続実行しても複合キーのソートは難しいですよ？
また、並べ替えた配列と現在値のインデックスを記憶しておけば都度の検索は必要ないですね？

Option Explicit

Private key()
'-------------------------------------------------
Private Sub keyset() 'ユニークデータ抽出とソート
　　Dim dic As Object
　　Dim i　 As Long
　　Dim v

　　Set dic = CreateObject("scripting.dictionary")
　　With Range("A1").CurrentRegion
　　　　v = Intersect(.Resize(, 2), .Offset(1)).Value
　　End With
　　For i = 1 To UBound(v)
　　　　dic(v(i, 2) & vbNullChar & v(i, 1)) = Empty
　　Next
　　key() = dic.keys
　　QSort key(), 0, UBound(key)

　　Set dic = Nothing
End Sub
'-------------------------------------------------
Private Sub QSort(ByRef Ary(), _
　　　　　　　　　ByVal Lo As Long, _
　　　　　　　　　ByVal Up As Long)
　　Dim i　As Long
　　Dim j　As Long
　　Dim ac, tmp

　　If Lo >= Up Then Exit Sub
　　ac = Ary((Up + Lo) \ 2)
　　i = Lo - 1
　　j = Up + 1
　　Do
　　　　Do
　　　　　　i = i + 1
　　　　Loop While Ary(i) < ac
　　　　Do
　　　　　　j = j - 1
　　　　Loop While Ary(j) > ac
　　　　If i >= j Then Exit Do
　　　　tmp = Ary(j)
　　　　Ary(j) = Ary(i)
　　　　Ary(i) = tmp
　　Loop
　　If Lo < i - 1 Then QSort Ary(), Lo, i - 1
　　If Up > j + 1 Then QSort Ary(), j + 1, Up
End Sub
'-------------------------------------------------
Private Sub 確認()
　　Static n As Long
　　Dim p　　As Long
　　Dim x(1 To 2) As String

　　p = InStr(key(n), vbNullChar)
　　x(2) = Mid$(key(n), 1, p - 1)
　　x(1) = Mid$(key(n), p + 1)
　　MsgBox "key1= " & x(2) & vbLf & "key2= " & x(1)
　　n = n + 1
End Sub

お礼

end_uさん、ありがとうございます！
Dictionaryコレクション、すごいですね！！！(@_@)
これはキーの重複だけに使うのはもったいなくて（当たり前）いろいろ使えますね。
どうもありがとうございます！！！
＞都度の検索は必要ない
いえ、プログラムを途中で中断して、何ならWindowsも終了して他の人に渡して帰っちゃう運用も考えられるので、現在のシート状態とフィルター状態だけを使ってやりたいと思いました。。。

オンメモリで、Dictionaryコレクションを使って、Dictionaryコレクションのキーのソートはクイックソートを使って一応作ってみました。
みなさんに教えていただいた部分のカッコよさと自分で考えた部分のダサさの違いの気持ち悪さをお楽しみください (^^;;;
（半角スペース２個を全角スペース１個にしています）
Option Explicit
Option Compare Text
Const keyCol1 As Long = 1 'キーのカラム位置１
Const keyCol2 As Long = 3 'キーのカラム位置２（使用しないときはゼロ）
Const keyCol3 As Long = 2 'キーのカラム位置３（使用しないときはゼロ）
Const cnsDelim As String = "_Delim__Delim__Delim_"
　　'タブ文字だとDictionaryのキーに入れたらウォッチ式で消えるような気がした
Sub test()
　　'データが入っている領域
　　Dim myRange As Range
　　Set myRange = Range(Cells(1, 1), ActiveCell.SpecialCells(xlLastCell))

　　'オートフィルターされていないときは最初の１回として区別する
　　Dim firstTime As Boolean
　　If Not ActiveSheet.FilterMode Then
　　　　firstTime = True
　　Else
　　　　firstTime = False
　　　　ActiveSheet.ShowAllData 'オートフィルターされているので解除する
　　End If

　　'領域を配列に入れる
　　Dim arr As Variant
　　arr = Range(Cells(2, 1), ActiveCell.SpecialCells(xlLastCell))
（補足に続く）

補足

（お礼から続き）
　　'Dictionaryコレクション
　　Dim dic As Variant, keys As Variant, i As Long, buf As String
　　Set dic = CreateObject("Scripting.Dictionary")
　　On Error Resume Next
　　For i = LBound(arr) To UBound(arr)
　　　　'キーを優先する順にデリミタをはさんでつなげておく
　　　　buf = arr(i, keyCol1)
　　　　If keyCol2 <> 0 Then
　　　　　　buf = buf + cnsDelim + arr(i, keyCol2)
　　　　　　If keyCol3 <> 0 Then
　　　　　　　　buf = buf + cnsDelim + arr(i, keyCol3)
　　　　　　End If
　　　　End If
　　　　dic.Add buf, "foo" 'キーの重複確認だけなら値はなんでもいいような気がする
　　Next i
　　On Error GoTo 0
　　keys = dic.keys
　　qSort keys, LBound(keys), UBound(keys) 'キーをソートする

　　Dim filters As Variant

　　'最初の１回であれば、最初のキーでフィルターする
　　If firstTime Then
　　　　filters = Split(keys(0), cnsDelim)
　　　　myRange.AutoFilter Field:=keyCol1, Criteria1:=filters(0)
　　　　If keyCol2 <> 0 Then
　　　　　　myRange.AutoFilter Field:=keyCol2, Criteria1:=filters(1)
　　　　　　If keyCol3 <> 0 Then
　　　　　　　　myRange.AutoFilter Field:=keyCol3, Criteria1:=filters(2)
　　　　　　End If
　　　　End If
　　　　setVisible '最初の見える行にカーソルを移動する
　　　　Exit Sub
　　End If

　　'最初の１回でないので、現在カーソルがある行のキーの次のキーでフィルターする
　　For i = 1 To dic.Count - 1
　　　　Dim curkey As String
　　　　curkey = Cells(ActiveCell.Row, keyCol1)
　　　　If keyCol2 <> 0 Then
　　　　　　curkey = curkey + cnsDelim + Cells(ActiveCell.Row, keyCol2)
　　　　　　If keyCol3 <> 0 Then
　　　　　　　　curkey = curkey + cnsDelim + Cells(ActiveCell.Row, keyCol3)
　　　　　　End If
　　　　End If
　　　　If curkey < keys(i) Then
　　　　　　filters = Split(keys(i), cnsDelim)
　　　　　　myRange.AutoFilter Field:=keyCol1, Criteria1:=filters(0)
　　　　　　If keyCol2 <> 0 Then
　　　　　　　　myRange.AutoFilter Field:=keyCol2, Criteria1:=filters(1)
　　　　　　　　If keyCol3 <> 0 Then
　　　　　　　　　　myRange.AutoFilter Field:=keyCol3, Criteria1:=filters(2)
　　　　　　　　End If
　　　　　　End If
　　　　　　Exit For
　　　　End If
next_for:
　　Next i
　　If Not ActiveSheet.FilterMode Then
　　　　MsgBox "no more keys"
　　Else
　　　　setVisible '最初の見える行にカーソルを移動する
　　End If
End Sub
Sub setVisible()
　　Cells(1, keyCol1).Select
　　ActiveCell.Offset(1, 0).Select
　　While ActiveCell.EntireRow.Hidden
　　　　ActiveCell.Offset(1, 0).Select
　　Wend
End Sub
Sub qSort(arr As Variant, ByVal iMin As Long, iMax As Long)
'クイックソート
'http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_800.html?を参考にした
'未だによくわかってない
'変数名を分かりやすくしたつもりが、かえって分かりにくくなっている～
　　Dim iCent As Long
　　Dim i As Long
　　Dim j As Long
　　Dim vCent As String
　　Dim vTemp As String

　　If iMin >= iMax Then Exit Sub
　　iCent = (iMin + iMax) / 2
　　vCent = arr(iCent)
　　arr(iCent) = arr(iMin)
　　j = iMin
　　i = iMin + 1
　　Do While i <= iMax
　　　　If arr(i) < vCent Then
　　　　　　j = j + 1
　　　　　　vTemp = arr(j)
　　　　　　arr(j) = arr(i)
　　　　　　arr(i) = vTemp
　　　　End If
　　　　i = i + 1
　　Loop
　　arr(iMin) = arr(j)
　　arr(j) = vCent
　　Call qSort(arr, iMin, j - 1)
　　Call qSort(arr, j + 1, iMax)
End Sub

回答No.6

kenpon24

失礼。qSortのここも列要素全体に直さないとダメか。意外と面倒ですね。
Do While i <= iMax
　　　　If arr(i, 1) < vCent Then
　　　　　　j = j + 1
for k = 1 to ubound(arr, 2)
　　　　　　vTemp = arr(j, k)
　　　　　　arr(j, k) = arr(i, k)
　　　　　　arr(i, k) = vTemp
next k
　　　　End If
　　　　i = i + 1
　　Loop

回答No.5

kenpon24

もう少し整理して書いたらきれいな処理になりそうですが、
頭が良く回転して非常にノリノリで作った感が伝わってくるコードですね。

えーっと処理はこんなところですか。
とりあえず動いているならよしとしましょう。
1,フィルタを解除
2,データ取得
3,配列ソート
4,現在差している値取得
5,配列を順次探索して現在値より大きければその値でフィルタ

昇順に並べるqSortが実装済みなので、ほんのひと工夫で複数列もいけそうですね。

Sub qSort(arr As Variant, ByVal iMin As Long, iMax As Long)を
Sub qSort(arr As Variant, ByVal iMin As Long, iMax As Long, key)としてqSort内のarr(iCent, 1)とかをarr(iCent, key)とします。

'クイックソートの呼び出し
ここに1枚皮を被せましょう。
'第3優先まで対応のソート関数 key2とkey3はデフォルトの引数で0を指定しておく。
'最低限、第1優先は必要
Sub mySort(arr, key1 As Integer, Optional key2 As Integer = 0, Optional key3 As Integer = 0)

Dim iMax As Long
Dim iMin As Long
iMin = LBound(arr)
iMax = UBound(arr)

'優先度の低い項目からソートしていく
If key3 <> 0 Then
Call qSort(arr, iMin, iMax, key3)
End If

If key2 <> 0 Then
Call qSort(arr, iMin, iMax, key2)
End If

Call qSort(arr, iMin, iMax, key1)

End Sub

これでkey1にキイ2を、key2にキイ1を設定すれば複数列に渡ってソートできるでしょう。

あとは2番で複数列を取得し、
優先順位をつけてmySort(arr, 2, 1)などとして
4番と5番で隣の列の値まで取得して比較を行えば動くでしょう。たぶん。

お礼

kenpon24さん、end-uさん、今日は本当にありがとうございました。
キー１個（配列１本）が出来たからあとはチョイチョイでキーを増やせると思っていたんですが、お察しのとおり、たぶんクイックソートを使ったせいもあって、キーを増やすのはものすごく大変でした。
８時ぐらいまでがんばったのですが、さすがに他の仕事も押してきたので、本日中の完成は断念しました。
続きは月曜になりますが、ここまで書いてくださったので、さすがにもう一押しで自分で書けると思います。
本当にありがとうございます。

回答No.4

kenpon24

＞行全体をvMaxという変数に入れようと思った
配列のインデックス番号だけ覚えておけばいいと思います。

あまりしんどいようなら#2さんの意見を使うといいと思いますよ。

たとえば
1, ブックの起動時に対象とするシートをコピーして
2, #2さんの方法でユニークな情報に絞り込んでソートし、
3, そのシートの文字列情報をメモリに取り込んで
4, コピーしたシートを削除

としても同じ効能が得られます。
メモリに取り込むまではApplication.ScreenUpdating = Falseにしてユーザーに意識させない方向で。

お礼

＞配列のインデックス番号だけ覚えておけばいいと思います。
そうかーーーー！！！！！
ああ～～～俺のバカ。
ありがとうございます！！！！！！

そうとは知らず、とりあえず１次元配列を使ってキー１個版を作りました。
ご回答をいただかなければ書けなかったとは思いますが、ご回答を十分参考にできている気もしません ;;;

＞Application.ScreenUpdating = False
こんなものもあるんですね。。。
本当にありがとうございます。

'半角空白２個を全角空白１個に置き換えてインデントを表現しています。
Option Explicit
Const keyCol As Long = 3 'キーのカラム位置
Sub test()
　　'データが入っている領域
　　Dim myRange As Range
　　Set myRange = Range(Cells(1, 1), ActiveCell.SpecialCells(xlLastCell))

　　'オートフィルターされていないときは最初の１回として区別する
　　Dim firstTime As Boolean
　　If Not ActiveSheet.FilterMode Then
　　　　firstTime = True
　　Else
　　　　firstTime = False
　　　　ActiveSheet.ShowAllData 'オートフィルターされているので解除する
　　End If

　　'キーを配列に入れる
　　Dim arr As Variant
　　Dim lastRow As Long
　　lastRow = Cells(1, 1).End(xlDown).Row 'さっきもSpecialCellsを使って似たようなことをやった気がするが・・・
　　arr = Range(Cells(2, keyCol), Cells(lastRow, keyCol)).Value

　　'クイックソートの呼び出し（実はあまり理解していない）
　　Dim iMax As Long
　　Dim iMin As Long
　　iMin = LBound(arr)
　　iMax = UBound(arr)
　　Call qSort(arr, iMin, iMax) 'クイックソート
　　'補足に続く (^^;

補足

'お礼からの続き (^^;
　　'最初の１回であれば、第１のキーでフィルターする
　　If firstTime Then
　　　　myRange.AutoFilter Field:=keyCol, Criteria1:=arr(1, 1)
　　　　setVisible '最初の見える行にカーソルを移動する
　　　　Exit Sub
　　End If

　　'最初の１回でないので、現在カーソルがある行のキーの次のキーでフィルターする
　　Dim curKey As String
　　curKey = Cells(ActiveCell.Row, keyCol)

　　Dim i As Long
　　For i = iMin To iMax　　'配列をなめて
　　　　If arr(i, 1) > curKey Then　'現在のキーよりも大きかったらフィルター
　　　　　　myRange.AutoFilter Field:=keyCol, Criteria1:=arr(i, 1)
　　　　　　setVisible '最初の見える行にカーソルを移動する
　　　　　　Exit Sub
　　　　End If
　　Next i

　　'最後のキーにカーソルがあったら、エラーを出す
　　MsgBox "no more keys"
End Sub
Sub qSort(arr As Variant, ByVal iMin As Long, iMax As Long)
'クイックソート
'http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_800.htmlを参考にした
'変数名を分かりやすくしたつもりが、かえって分かりにくくなっている～
　　Dim iCent As Long
　　Dim i As Long
　　Dim j As Long
　　Dim vCent As String
　　Dim vTemp As String

　　If iMin >= iMax Then Exit Sub
　　iCent = (iMin + iMax) / 2
　　vCent = arr(iCent, 1)
　　arr(iCent, 1) = arr(iMin, 1)
　　j = iMin
　　i = iMin + 1
　　Do While i <= iMax
　　　　If arr(i, 1) < vCent Then
　　　　　　j = j + 1
　　　　　　vTemp = arr(j, 1)
　　　　　　arr(j, 1) = arr(i, 1)
　　　　　　arr(i, 1) = vTemp
　　　　End If
　　　　i = i + 1
　　Loop
　　arr(iMin, 1) = arr(j, 1)
　　arr(j, 1) = vCent
　　Call qSort(arr, iMin, j - 1)
　　Call qSort(arr, j + 1, iMax)
End Sub
Sub setVisible()
'最初の見える行に移動
　　Cells(1, keyCol).Select
　　ActiveCell.Offset(1, 0).Select
　　While ActiveCell.EntireRow.Hidden
　　　　ActiveCell.Offset(1, 0).Select
　　Wend
End Sub

回答No.3

kenpon24

とりあえずお悩みの箇所はそんなに面倒なところでなくてよかった(^ ^
これから大変でしょうが頑張ってください。

Variant型の配列にした場合、アクセス方法は2次元で指定する必要があります。
1列しかなくても、下記のように書く必要があります。
arr(L, 1)

もし行が1行しかない場合はarr(L)でないとアクセスできないのがいやらしいところなんですが、今回のケースではそれもないでしょう。
ということでarr(L, 1)としてvMaxに入れてあげてください。

時間があるときならもう少し詳しく書けると思います

お礼

ありがとうございます。
書き方が悪くて伝わっていませんでしたね (T_T)
arr(L, 1)
これはＬ行１列目の単一のセルですね。
そうではなくて、Ｌ行目全体（二次元配列の要素である行全体）を入れようと思ったんです。
トンチンカンなコードで誤解させてしまってスミマセン(^^;;;
mySort関数は

Ａ｜あ
Ｂ｜あ
Ａ｜あ
Ａ｜い
Ｃ｜い
Ａ｜い
Ｂ｜う

という二次元配列を入力して、たとえばキー１＝＞キー２の順に昇順ソートであれば

Ａ｜あ
Ａ｜あ
Ａ｜い
Ａ｜い
Ｂ｜あ
Ｂ｜う
Ｃ｜い

という風にソートされた２次元配列を返す必要があったので、普通のソートのように単一の値を比較して入れ替えるのではなくて、たとえば

Ａ｜あ

という行全体をvMaxという変数に入れようと思ったんです。

＞これから大変でしょうが頑張ってください。

確かに！！！(^o^)
ありがとうございます。

回答No.2

end-u

>Excelを終了して（フィルター状態は保存）途中からやることもあることです。
との事なので、作業用シートに各列ユニークな値を抜き出して記録しておけば良いのではないでしょうか。
非表示シートでも構わないと思います。
各列ユニークな値を抜き出すには、[フィルタオプションの設定]（AdvancedFilterメソッド）で抜き出せば良いです。
抜き出したユニーク値のセル範囲をOffset(1)でずらしながら選択させれば次の値が簡単に設定できます。

発展形についても、AdvancedFilterで複合列でのユニーク値を記録しておけば良いですね。

余談かもしれませんが『カーソル位置を常に見つかったのの中で先頭に戻す』とは
可視セルの１つ目のセルという事ですね。

Sub test()
　　Dim r As Range

　　On Error Resume Next
　　With ActiveSheet.AutoFilter.Range
　　　　Set r = Intersect(.Cells, .Offset(1), ActiveCell.EntireColumn) _
　　　　　　　　.SpecialCells(xlCellTypeVisible)
　　End With
　　On Error GoTo 0
　　If Not r Is Nothing Then
　　　　r.Cells(1).Select
　　　　Set r = Nothing
　　End If
End Sub

簡易的にSendKeysを使ってもいいかもしれませんが。
Dim r As Range

On Error Resume Next
Set r = Intersect(ActiveSheet.AutoFilter.Range, ActiveCell.EntireColumn).Cells(1)
On Error GoTo 0
If Not r Is Nothing Then
　　r.Cells(1).Select
　　Set r = Nothing
　　SendKeys "{down}"
End If

お礼

ありがとうございます。
せっかくExcelには組み込みのフィルターとソート機能があるので、作業シートを非表示で作成する方法はまず考えましたが、複数のシートを途中で作業中断して切り替えたり、人にシートを渡したりすることさえありうるので、採用を断念しました。

＞各列ユニークな値を抜き出すには、[フィルタオプションの設定]（AdvancedFilterメソッド）で抜き出せば良いです。
＞抜き出したユニーク値のセル範囲をOffset(1)でずらしながら選択させれば次の値が簡単に設定できます。

をヒントにオンメモリでやる方法を考えます。
どうもありがとうございます！

補足

フト、作業シートは今開いているシートの右側でやればいいかもしれないとも思いました。
いまはオンメモリでやる方法を研究していますが、いよいよ行き詰ったらそちらも研究します。

回答No.1

kenpon24

これは特定キーで昇順にソートされた
検索用のインデックス配列を作りたいという話ですね。

　｜キ｜キ
　｜イ｜イ
＃｜１｜２
－＋－－－－
１｜Ａ｜あ＜＝カーソル位置
２｜Ｂ｜あ
３｜Ａ｜あ
４｜Ａ｜い
５｜Ｃ｜い
６｜Ａ｜い
７｜Ｂ｜う

というデータがあった場合、ボタンを押したらこのデータをまず配列に取り込みます。
セルを配列に入れるという方法が速いでしょう
http://officetanaka.net/excel/vba/speed/s11.htm

次に優先するキーを考慮しつつ昇順にソートします。
具体的には配列とkeyを受け取る関数を作って、その中で並べ替えを行います。

function mySortの例(配列 as 型(Variantかな), key1 as string, optional key2 as string = "", optional key3 as string = "")
配列のソートの実装 配列のソートは調べてください
end function

例の通りに動かしたいなら、ここで配列の中はこんな感じになるはず
(キイ２を第1優先、キイ1を第2優先)
Ａ｜あ
Ａ｜あ
Ｂ｜あ
Ａ｜い
Ａ｜い
Ｃ｜い
Ｂ｜う

で、この配列を上から走査していって、1列目もしくは2列目が現在格納されている
最終インデックス配列の要素と異なれば新たなインデックス配列に格納する

Dim インデックス配列() as string

for i = 0 to Ubound(配列)
for j = 0 to インデックス配列の要素数
if インデックス配列の1列目と等しい And インデックス配列の2列目と等しい then
goto NextArray
end
next j

インデックス配列の要素数 = インデックス配列の要素数 + 1
redim preserve インデックス配列(0 to インデックス配列の要素数)

インデックス配列に配列の要素を格納

NextArray:
next i

ここでインデックス配列の中はこんな感じです。
Ａ｜あ
Ｂ｜あ
Ａ｜い
Ｃ｜い
Ｂ｜う

ここまでくればあと少し。
現在表示されている値をどうにかして取得して(やり方を忘れました)
インデックス配列と比較していきます。

同じ要素が見つかったら、その次の要素でフィルタをかければOKです。

ちなみに速度に影響が少なければソートするだけでも同じような動作をさせることができます。

シートに値を追加することがないのであれば、このブックを起動したときに上記の動作を行って、
検索用の配列をグローバル変数に格納して保持しておくのも一つの手です。

お礼

ありがとうございます。
Variant型の変数にセル範囲をズバーンと入れてやれば二次元配列になって速度も速いというのは非常にそそられます。

ということで、まずソートを実装するところまでやりかけてみましたが、２時間ほど詰まっています (^^;
もしお時間があればさらにご教示賜れば幸甚です。

Option Explicit
Sub test()
Dim arr As Variant
arr = Range("a2", Cells.SpecialCells(xlCellTypeLastCell))
mySort arr
End Sub
Sub mySort(ByRef arr)
Dim L As Long
Dim U As Long
Dim vMax
L = LBound(arr)
U = UBound(arr)
vMax = arr(L)
Stop
End Sub

このようにしてみましたが、
vMax = arr(L)
のところで
「実行時エラー'9' インデックスが有効範囲にありません」
と言われます。

要するに、２次元配列を行についてソートしようと思ったので、２次元配列の入ったarrのある要素（ある行、１次元配列）をvMaxに代入しようと思いましたが、これができないようです。

Cells.SpecialCells(xlCellTypeLastCell)はやらなくて、横はせいぜい２６列、縦は無制限なのでrange("a2:z65535")（Excel2003か2007で運用するので2003の最大にしてみた）とでもすればいいのかもしれないですが、Excelは平気でもぼくがテストするときにウォッチ式とか見るのに大変そうなので、こうしてみました (^^;

書きながらふと思いましたが、セルを配列に入れるところまでは大きさ不定の二次元配列にして、キーを入れるのは普通の１次元配列にして地味にforループでアクセスすればいいのかな・・・。

ダラダラしてすみませんが現状でした (^^;;;