いつもお世話になります。
オートフィルターの処理をマクロでやれという指令がきました。具体的に言うと、
#|キー
-+-
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の値でフィルターしてしまうかもしれないので気を付ける、というやり方は思いつくのですが・・・。
以上、よろしくお願いします。
No.8ベストアンサー
- 回答日時:
やっとまとまった時間が取れたのでよくよく見返してみると・・・間違ってますね。
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
kenpon24さん、本当にありがとうございました。
そうなんです、クイックソートは安定ソートじゃないのでキーが2個以上の場合は使わない方がいいんですね。
今回はオンメモリ+Dictionaryコレクション+キーはクイックソートでとりあえずの完成版となりました。
上のend_uさんへのお礼をご笑覧ください。
まだまだ汚いと思いますが、短くはなっています。
金曜日の午後と今朝と、通産8時間ぐらいの作業ですが、今回だけでなくすごくいろいろ教わってよかったです。
本当にみなさんありがとうございました。
No.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
この回答への補足
(お礼から続き)
'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/sub0 …を参考にした
'未だによくわかってない
'変数名を分かりやすくしたつもりが、かえって分かりにくくなっている~
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
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))
(補足に続く)
No.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
No.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番で隣の列の値まで取得して比較を行えば動くでしょう。たぶん。
kenpon24さん、end-uさん、今日は本当にありがとうございました。
キー1個(配列1本)が出来たからあとはチョイチョイでキーを増やせると思っていたんですが、お察しのとおり、たぶんクイックソートを使ったせいもあって、キーを増やすのはものすごく大変でした。
8時ぐらいまでがんばったのですが、さすがに他の仕事も押してきたので、本日中の完成は断念しました。
続きは月曜になりますが、ここまで書いてくださったので、さすがにもう一押しで自分で書けると思います。
本当にありがとうございます。
No.4
- 回答日時:
>行全体をvMaxという変数に入れようと思った
配列のインデックス番号だけ覚えておけばいいと思います。
あまりしんどいようなら#2さんの意見を使うといいと思いますよ。
たとえば
1, ブックの起動時に対象とするシートをコピーして
2, #2さんの方法でユニークな情報に絞り込んでソートし、
3, そのシートの文字列情報をメモリに取り込んで
4, コピーしたシートを削除
としても同じ効能が得られます。
メモリに取り込むまではApplication.ScreenUpdating = Falseにしてユーザーに意識させない方向で。
この回答への補足
'お礼からの続き (^^;
'最初の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/sub0 …を参考にした
'変数名を分かりやすくしたつもりが、かえって分かりにくくなっている~
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
>配列のインデックス番号だけ覚えておけばいいと思います。
そうかーーーー!!!!!
ああ~~~俺のバカ。
ありがとうございます!!!!!!
そうとは知らず、とりあえず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) 'クイックソート
'補足に続く (^^;
No.3
- 回答日時:
とりあえずお悩みの箇所はそんなに面倒なところでなくてよかった(^ ^
これから大変でしょうが頑張ってください。
Variant型の配列にした場合、アクセス方法は2次元で指定する必要があります。
1列しかなくても、下記のように書く必要があります。
arr(L, 1)
もし行が1行しかない場合はarr(L)でないとアクセスできないのがいやらしいところなんですが、今回のケースではそれもないでしょう。
ということでarr(L, 1)としてvMaxに入れてあげてください。
時間があるときならもう少し詳しく書けると思います
ありがとうございます。
書き方が悪くて伝わっていませんでしたね (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^)
ありがとうございます。
No.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
この回答への補足
フト、作業シートは今開いているシートの右側でやればいいかもしれないとも思いました。
いまはオンメモリでやる方法を研究していますが、いよいよ行き詰ったらそちらも研究します。
ありがとうございます。
せっかくExcelには組み込みのフィルターとソート機能があるので、作業シートを非表示で作成する方法はまず考えましたが、複数のシートを途中で作業中断して切り替えたり、人にシートを渡したりすることさえありうるので、採用を断念しました。
>各列ユニークな値を抜き出すには、[フィルタオプションの設定](AdvancedFilterメソッド)で抜き出せば良いです。
>抜き出したユニーク値のセル範囲をOffset(1)でずらしながら選択させれば次の値が簡単に設定できます。
をヒントにオンメモリでやる方法を考えます。
どうもありがとうございます!
No.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です。
ちなみに速度に影響が少なければソートするだけでも同じような動作をさせることができます。
シートに値を追加することがないのであれば、このブックを起動したときに上記の動作を行って、
検索用の配列をグローバル変数に格納して保持しておくのも一つの手です。
ありがとうございます。
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ループでアクセスすればいいのかな・・・。
ダラダラしてすみませんが現状でした (^^;;;
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) Excelで、カーソルの移動が異常です。 1 2022/06/15 20:54
- Word(ワード) Wordで破線をひくにはどうすれば良いのでしょうか。 5 2022/06/17 13:24
- Visual Basic(VBA) VBA 画面上のカーソルに文字数字を入力するコードを教えて下さい 1 2022/10/30 10:31
- iPad これまでタブレットは何台使ったか数え切れないほどですが、今回iPadを初めて手に入れました。 全体的 5 2022/08/07 18:34
- Windows 10 Windows11タスクバーやエクスプローラー、スタートメニュー 動画全画面時にカーソルが見えない 1 2022/04/08 00:03
- Excel(エクセル) エクセルで書式設定とフィルタの組み合わせでうまく行かないのですが 4 2022/10/07 10:02
- マウス・キーボード テンキーの設定がおかしくなっています。 5 2023/08/09 15:35
- マウス・キーボード ブラインドタッチの練習法 10 2022/07/19 14:28
- 据え置き型ゲーム機 Switchで太鼓の達人をやってるのですが、プロコンが使いにくくて仕方がないです。何が使いにくいって 1 2023/07/01 10:46
- その他(プログラミング・Web制作) pythonでのカーソル移動がずれる 2 2023/07/30 08:51
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
VBA 変数名に変数を使用したい。
-
C言語の enum の使い方
-
Excel2010のinputboxで複数デー...
-
定数配列の書き方
-
VBAテキストボックスについて
-
順列をランダムに発生するプロ...
-
コンボボックスのインデックス...
-
配列のペースト出力結果の書式...
-
母親の血液中の胎盤遺伝
-
VBA フォルダ内のファイルを、...
-
VBAの動的配列について
-
構造体配列内の文字列検索のよ...
-
2次元配列の初期値
-
コードの簡略化 VBA
-
テキストボックの文字を一行ず...
-
dimを使わずにredimを使う場合
-
C#でbyte配列から画像を表示さ...
-
VBAにて、配列のデータを一度に...
-
Dir関数で読み取り順を操作でき...
-
Segmentation Fault (メモリ制限?)
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
VBA 変数名に変数を使用したい。
-
vba フィルター 複数条件 3つ以...
-
C#でbyte配列から画像を表示さ...
-
Excel2010のinputboxで複数デー...
-
エクセルでXY座標に並べられた...
-
構造体配列の特定のメンバーをF...
-
定数配列の書き方
-
コンボボックスのインデックス...
-
OutOfMemoryExceptionの回避策...
-
Dir関数で読み取り順を操作でき...
-
CheckBoxの配列化
-
構造体配列内の文字列検索のよ...
-
COBOLの基本的な事なので...
-
Redim とEraseの違いは?
-
VBAで配列引数を値渡しできない...
-
2次元配列の初期値
-
配列の中の最大値とそのインデ...
-
VB6からの移行したいけど、VB.N...
-
大量の変数を定義するにはどう...
-
VB6のメモリ解放に関して
おすすめ情報