こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

#|キー
-+-
1|A<=カーソル位置
2|B
3|A
4|A
5|C
6|A
7|B

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

#|キー
-+-
1|A<=カーソル位置
=====隠れ
3|A
4|A
=====隠れ
6|A



#|キー
-+-
=====隠れ
2|B<=カーソル位置
=====隠れ
7|B



#|キー
-+-
=====隠れ
5|C<=カーソル位置
=====隠れ

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

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

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

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

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

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

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

 |キ|キ
 |イ|イ
#|1|2
-+----
1|A|あ<=カーソル位置
2|B|あ
3|A|あ
4|A|い
5|C|い
6|A|い
7|B|う

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

 |キ|キ
 |イ|イ
#|1|2
-+----
1|A|あ<=カーソル位置
=====隠れ
3|A|あ
=====隠れ



 |キ|キ
 |イ|イ
#|1|2
-+----
=====隠れ
2|B|あ<=カーソル位置
=====隠れ



 |キ|キ
 |イ|イ
#|1|2
-+----
=====隠れ
4|A|い<=カーソル位置
=====隠れ
6|A|い
=====隠れ

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

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

投稿日時 - 2009-04-17 11:37:11

QNo.4886145

すぐに回答ほしいです

質問者が選んだベストアンサー

やっとまとまった時間が取れたのでよくよく見返してみると・・・間違ってますね。
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

'半角空白2個を全角空白1個に置き換えてインデントを表現しています。
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

投稿日時 - 2009-04-18 13:17:48

お礼

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

投稿日時 - 2009-04-20 10:59:43

このQ&Aは役に立ちましたか?

5人が「このQ&Aが役に立った」と投票しています

回答(8)

ANo.7

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

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

投稿日時 - 2009-04-18 02:12:53

補足

(お礼から続き)
  '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
  
  '最初の1回であれば、最初のキーでフィルターする
  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
  
  '最初の1回でないので、現在カーソルがある行のキーの次のキーでフィルターする
  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

投稿日時 - 2009-04-20 10:53:07

お礼

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

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

投稿日時 - 2009-04-20 10:52:40

ANo.6

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

投稿日時 - 2009-04-17 21:27:26

ANo.5

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

えーっと処理はこんなところですか。
とりあえず動いているならよしとしましょう。
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番で隣の列の値まで取得して比較を行えば動くでしょう。たぶん。

投稿日時 - 2009-04-17 20:56:10

お礼

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

投稿日時 - 2009-04-18 01:34:27

ANo.4

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

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

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

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

投稿日時 - 2009-04-17 16:56:59

補足

'お礼からの続き (^^;
  '最初の1回であれば、第1のキーでフィルターする
  If firstTime Then
    myRange.AutoFilter Field:=keyCol, Criteria1:=arr(1, 1)
    setVisible '最初の見える行にカーソルを移動する
    Exit Sub
  End If
  
  '最初の1回でないので、現在カーソルがある行のキーの次のキーでフィルターする
  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

投稿日時 - 2009-04-17 18:16:01

お礼

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

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

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

'半角空白2個を全角空白1個に置き換えてインデントを表現しています。
Option Explicit
Const keyCol As Long = 3 'キーのカラム位置
Sub test()
  'データが入っている領域
  Dim myRange As Range
  Set myRange = Range(Cells(1, 1), ActiveCell.SpecialCells(xlLastCell))
  
  
  'オートフィルターされていないときは最初の1回として区別する
  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) 'クイックソート
  '補足に続く (^^;

投稿日時 - 2009-04-17 18:15:45

ANo.3

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

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

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

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

投稿日時 - 2009-04-17 15:36:58

お礼

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

A|あ
B|あ
A|あ
A|い
C|い
A|い
B|う

という二次元配列を入力して、たとえばキー1=>キー2の順に昇順ソートであれば

A|あ
A|あ
A|い
A|い
B|あ
B|う
C|い

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

A|あ

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

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

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

投稿日時 - 2009-04-17 15:51:27

ANo.2

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

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



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

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

投稿日時 - 2009-04-17 13:41:59

補足

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

投稿日時 - 2009-04-17 16:01:02

お礼

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

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

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

投稿日時 - 2009-04-17 15:06:21

ANo.1

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

 |キ|キ
 |イ|イ
#|1|2
-+----
1|A|あ<=カーソル位置
2|B|あ
3|A|あ
4|A|い
5|C|い
6|A|い
7|B|う

というデータがあった場合、ボタンを押したらこのデータをまず配列に取り込みます。
セルを配列に入れるという方法が速いでしょう
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

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

で、この配列を上から走査していって、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

ここでインデックス配列の中はこんな感じです。
A|あ
B|あ
A|い
C|い
B|う


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

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

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

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

投稿日時 - 2009-04-17 13:09:36

お礼

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

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

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' インデックスが有効範囲にありません」
と言われます。

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

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

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

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

投稿日時 - 2009-04-17 15:18:05

あなたにオススメの質問