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

Question

いつもお世話になります。
オートフィルターの処理をマクロでやれという指令がきました。具体的に言うと、

＃｜キー
－＋－
１｜Ａ＜＝カーソル位置
２｜Ｂ
３｜Ａ
４｜Ａ
５｜Ｃ
６｜Ａ
７｜Ｂ

のようなシートがあった場合、ツールバーのボタンをクリックするたびに

＃｜キー
－＋－
１｜Ａ＜＝カーソル位置
＝＝＝＝＝隠れ
３｜Ａ
４｜Ａ
＝＝＝＝＝隠れ
６｜Ａ

★

＃｜キー
－＋－
＝＝＝＝＝隠れ
２｜Ｂ＜＝カーソル位置
＝＝＝＝＝隠れ
７｜Ｂ

★

＃｜キー
－＋－
＝＝＝＝＝隠れ
５｜Ｃ＜＝カーソル位置
＝＝＝＝＝隠れ

のように遷移しなさいという問題です。

やっかいなのは、ボタンを押す間に別の作業が入る（同じマクロの連続実行の中で遷移させることができない。Excelを終了して（フィルター状態は保存）途中からやることもあることです。

最初は
（１）フィルターがないときはカーソル位置のデータでフィルターする
（２）フィルターがあるときは
（（１））フィルターを解除する
（（２））カーソル位置のキーを覚えておく
（（３））下になめていって、覚えているのと違うキーが出てきたらその値でフィルターする
みたいにしていたのですが、カーソル位置を常に見つかったのの中で先頭に戻しなさい、と言われたので、使えなくなってしまいました。（今ここです）

キーの値のバリエーションを配列に入れて、言わば自前でフィルターを作ってやればいいのかもしれませんが、マクロを実行するたびに全データをスキャンすることになるので、遅くなると思います。

手動で「データ」＝＞「オートフィルタ」をやったときのフィルターの一覧を取り出して配列に入れることができれば一番いいと思うのですが、その方法が見出せませんでした。

ということで、
質問１：「データ」＝＞「オートフィルタ」をやったときのフィルターの一覧を取り出して配列に入れることはできるでしょうか
質問２：上の題意でどのようなプログラムが考えられるでしょうか

次は、同じ問題の発展形なのですが、

　｜キ｜キ
　｜イ｜イ
＃｜１｜２
－＋－－－－
１｜Ａ｜あ＜＝カーソル位置
２｜Ｂ｜あ
３｜Ａ｜あ
４｜Ａ｜い
５｜Ｃ｜い
６｜Ａ｜い
７｜Ｂ｜う

のようになったとき、ボタンを押すたびに、

　｜キ｜キ
　｜イ｜イ
＃｜１｜２
－＋－－－－
１｜Ａ｜あ＜＝カーソル位置
＝＝＝＝＝隠れ
３｜Ａ｜あ
＝＝＝＝＝隠れ

★

　｜キ｜キ
　｜イ｜イ
＃｜１｜２
－＋－－－－
＝＝＝＝＝隠れ
２｜Ｂ｜あ＜＝カーソル位置
＝＝＝＝＝隠れ

★

　｜キ｜キ
　｜イ｜イ
＃｜１｜２
－＋－－－－
＝＝＝＝＝隠れ
４｜Ａ｜い＜＝カーソル位置
＝＝＝＝＝隠れ
６｜Ａ｜い
＝＝＝＝＝隠れ

のように遷移しろというものですが、これもエレガントな書き方があるでしょうか。
一応キー１、キー２の値を配列にとって、キー１の個々の値でフィルターして、次にキー２の個々の値でフィルターする、ただし、キー１の値によってはありえないキー２の値でフィルターしてしまうかもしれないので気を付ける、というやり方は思いつくのですが・・・。

以上、よろしくお願いします。

kenpon24 · Accepted Answer

やっとまとまった時間が取れたのでよくよく見返してみると・・・間違ってますね。

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

end-u · Answer

>フト、作業シートは今開いているシートの右側でやればいいかもしれないとも思いました。

いえ、無ければ追加すれば良いだけの話です。

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

kenpon24 · Answer

失礼。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

kenpon24 · Answer

もう少し整理して書いたらきれいな処理になりそうですが、頭が良く回転して非常にノリノリで作った感が伝わってくるコードですね。えーっと処理はこんなところですか。とりあえず動いているならよしとしましょう。 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 · Answer

＞行全体をvMaxという変数に入れようと思った
配列のインデックス番号だけ覚えておけばいいと思います。

あまりしんどいようなら#2さんの意見を使うといいと思いますよ。

たとえば
1, ブックの起動時に対象とするシートをコピーして
2, #2さんの方法でユニークな情報に絞り込んでソートし、
3, そのシートの文字列情報をメモリに取り込んで
4, コピーしたシートを削除

としても同じ効能が得られます。
メモリに取り込むまではApplication.ScreenUpdating = Falseにしてユーザーに意識させない方向で。

kenpon24 · Answer

とりあえずお悩みの箇所はそんなに面倒なところでなくてよかった(^ ^
これから大変でしょうが頑張ってください。

Variant型の配列にした場合、アクセス方法は2次元で指定する必要があります。
1列しかなくても、下記のように書く必要があります。
arr(L, 1)

もし行が1行しかない場合はarr(L)でないとアクセスできないのがいやらしいところなんですが、今回のケースではそれもないでしょう。
ということでarr(L, 1)としてvMaxに入れてあげてください。

時間があるときならもう少し詳しく書けると思います

end-u · Answer

>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

kenpon24 · Answer

これは特定キーで昇順にソートされた
検索用のインデックス配列を作りたいという話ですね。

　｜キ｜キ
　｜イ｜イ
＃｜１｜２
－＋－－－－
１｜Ａ｜あ＜＝カーソル位置
２｜Ｂ｜あ
３｜Ａ｜あ
４｜Ａ｜い
５｜Ｃ｜い
６｜Ａ｜い
７｜Ｂ｜う

というデータがあった場合、ボタンを押したらこのデータをまず配列に取り込みます。
セルを配列に入れるという方法が速いでしょう
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です。

ちなみに速度に影響が少なければソートするだけでも同じような動作をさせることができます。

シートに値を追加することがないのであれば、このブックを起動したときに上記の動作を行って、
検索用の配列をグローバル変数に格納して保持しておくのも一つの手です。

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

やっとまとまった時間が取れたのでよくよく見返してみると・・・間違ってますね。

>フト、作業シートは今開いているシートの右側でやればいいかもしれないとも思いました。

この回答への補足

失礼。

もう少し整理して書いたらきれいな処理になりそうですが、

＞行全体をvMaxという変数に入れようと思った

この回答への補足

とりあえずお悩みの箇所はそんなに面倒なところでなくてよかった(^ ^

>Excelを終了して（フィルター状態は保存）途中からやることもあることです。

この回答への補足

これは特定キーで昇順にソートされた

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング