フィルタされた内容を配列に入れてから配列の中身でOR条件にてソートしたい

Question

前提

E列とAJ列の項目は重複しているものが多数あります。
2つのコードを載せますが１つ目のコードは動作は問題ないです。
関係あるかわからないので載せてます。

実現したいこと

こんな感じの表があります

• AJ列を一つのキーでソート
• ソートされた状態でE列に出てきている内容（以下の例だとE000113,E000114,E000115,E000116）を配列に入れる

• いったんフィルタを解除

• 配列の内容で(OR条件で)E列をソートしなおす

発生している問題

• ソートされた状態でE列に出てきている内容（以下の例だとE000113,E000114,E000115,E000116）を配列に入れる

↑配列には入っている様子…かとおもいきやE000113,E000114,E000115,E000116のあと空で５回msgboxがでます

• 配列の内容で(OR条件で)E列をソートしなおす

↑エラーはおきないですがフィルタがかかっていない状態です

エクセルVBA

Sub 共通親抽出()

     'マクロ実行画面の凍結
     Application.ScreenUpdating = False

     '変数宣言
     Dim zuban As Variant
     Dim endRow As Long

    ' 最下行の取得
    endRow = Cells(Rows.Count, 36).End(xlUp).Row
    
     '抽出キーの入力指示
     zuban = InputBox("変更する図番を版数抜で入力して下さい。")

     'キャンセルした場合の処理
     If zuban = Empty Then
         Exit Sub
     End If

     'オートフィルタがかかっていなかったらかける
     'かかっていたら念の為一度解除し再設定
     If ActiveSheet.AutoFilterMode = False Then
         Range("A1:AS" & endRow).Select
         Selection.AutoFilter
     Else
         Selection.AutoFilter
         Range("A1:AS" & endRow).Select
         Selection.AutoFilter
     End If

        Range("E1").Select

     '「図番」の列（36列目）で、抽出キーを含むものを抽出
        Selection.AutoFilter Field:=36, Criteria1:="=*" & zuban & "*", Operator:=xlAnd
        'Range("E1").CurrentRegion.Offset(1, 0).Resize(Range("E1").CurrentRegion.Rows.Count - 1).Interior.Color = 65535
 
End Sub

Sub 図番でのソート後配列に格納して再度フィルタ()
    Dim d(100) '配列の数
    Dim Buff As Variant
    Range("E1").CurrentRegion.Select
    Set Buff = Range("A2:AS48").SpecialCells(xlCellTypeVisible)
    For Each Cl In Buff
    If Cl.Column = 5 Then
    d(k) = Cl
    k = k + 1
    MsgBox Cl　’ここで確認すると配列には入っている様子…かとおもいきやE000113,E000114,E000115,E000116のあと空で５回msgboxがでます
    End If
    Next

 Range("A2:AS48").AutoFilter 'フィルタ解除

 Dim MaxRow  As Long
    
    MaxRow = Cells(Rows.Count, 36).End(xlUp).Row
  

    Range(Cells(1, 5), Cells(MaxRow, 45)) _　
                .AutoFilter Field:=5, _
                Criteria1:=Cl, _
                Operator:=xlFilterValues
            
End Sub

補足情報（FW/ツールのバージョンなど）

エクセル2013です

修正①
改めて動作させたらすこし現象が違いました。
発生している問題書き換えしました
修正②
★②Cells（1，5）→Cells（1，1）に修正　不要な修正でした…。

Comments

[pig_vba]

Clはfor eachカウンターとして動かしてる以上終了条件満たしてループ抜けた時点で範囲外参照してませんかねこれ。ClにNULL入ってません?

[kumiko]

そうです！
発生している問題を編集しましたが空で5回msgboxがでてきます。
エラー停止はせず記載部分44行を丸々フィルタした状態になりました。

[bebebe_]

フィルターの抽出文字列はdになるのでは？

[kumiko]

bebebeさん
そのようですね。コメントありがとうございました。

Answer 1

（1027編集）大ガバをやらかしました。BuffをRange型に定義変更してるからUbound使えるわけなかったです。デバッグなしで直書きはやはり横着過ぎてダメですね。反省

Sub 図番でのソート後配列に格納して再度フィルタ()
    Dim d As Variant
    Dim Buff As Range
    'range型確定なので先に宣言
    Dim Cl As Range
    Dim maxRow As Long
    
    Dim ws As Worksheet: Set ws = ActiveSheet

    maxRow = ws.Cells(ws.Rows.Count, 36).End(xlUp).Offset(1, 0).Row - 1 '(最下行が非表示になってる可能性を考慮)
    Set Buff = ws.Range("E1:E" & maxRow).SpecialCells(xlCellTypeVisible)
    
    Dim k As Long
    k = 0
    ReDim d(Buff.Cells.Count) 'BuffはRange型なのでセル数を取得
    
    For Each Cl In Buff
        'ClはRangeオブジェクトだからvalueだけ記憶
         d(k) = Cl.Value
         k = k + 1
    Next
    


    maxRow = ws.Cells(Rows.Count, 36).End(xlUp).Row

    ws.Range("A2:AS" & maxRow).AutoFilter 'フィルタ解除
  

    ws.Range(ws.Cells(1, 5), ws.Cells(maxRow, 45)) _
                .AutoFilter Field:=1, _
                Criteria1:=d, _
                Operator:=xlFilterValues
                           

End Sub

尚、d(0)にはタイトルの”部品コード”が格納されてしまいますが、余計なキーと空キーはデータ範囲に存在しない分には問題ないので意図的に無視してます（k=0のときだけ処理飛ばせばいいだけですが、それを書くとfor eachを使ってる意義がなくなりますので可読性が下がります）

これで要望通りの使用になってる…はず。勉強不足で追記だらけで申し訳ない

Comments

[pig_vba]

空のMSGBOXが出てくるのはBuffにセットするセル範囲を48行目まで固定にしてるからです。
きっかりデータ格納行の最下行を取得してセットしておけばそういう不具合は出ません。

[kumiko]

ありがとうございます。動作確認しました。期待どうりに動きました。
途中途中の突っ込み、ありがたいです。かみしめます。

[kumiko]

ごめんなさい、ちょっと不具合が…。確認時間ください

[kumiko]

一番最初の番号、画像でいうところのAJ2の「E000113-00」でAJ列をソートした状態で動作させた時だけ「実行時エラー９　インデックスが有効範囲にありません」となって デバックで「d(k) = Cl.Value」が黄色くなります。
ソート結果が一行でも他のフィルタでは問題は起きないのですが…。

[pig_vba]

エラーが出る状態で該当行の直前に

Msgbox Cl.value

を追加して何が表示されるか確認してもらえますか?

[pig_vba]

今気づきましたがkの初期化式が入ってなかったので修正しました。

[kumiko]

修正されたコードで動作させてみたのですがやっぱりE000113-00のときのみ不具合が…
If k > 99 Then Exit For　
のあとに
MsgBox Cl.Value
をいれたところＡ1,B1,C1…と項目行を横に格納していました。※E000113-00のとき
具体的には空、空、空、空、部品コード、…といったかんじです
すみません、本日はこれ以降返信できなそうです

[pig_vba]

行データが格納…?済みませんが私の知識では根本原因の特定が難しそうです。

暫定版でどういった挙動をするか確認していただけますでしょうか。

[kumiko]

暫定版では
ReDim d(UBound(Buff))
の”UBond”に色がついて「コンパイルエラー：配列がありません」とでました。

私もいろいろ実験してみました。
まずは一行目を空行にすれば期待どうりの動作(E000113-00でソートした行の検索でもうまくいく)はしました。
でもやっぱりそれではちょっとモヤモヤするので1つ前に書いていただいたコードいじっていたところ
Set Buff = Range("E2:E" & maxRow).SpecialCells(xlCellTypeVisible) のところをRange("E1:E" & maxRow)にしたところ配列には”部品コード”,"E000113"と入って期待の動作をしてくれました。

配列に検索ワードを入れるには…というところからコードを考えはじめたので項目名を外さねばとE2から選択していたのですが結果的には項目名が入っても動作は同じでした。

一応うまくいったコード書きます。
★マークのところ私の追記です
↓
Sub 図番でのソート後配列に格納して再度フィルタ()
Dim d(100) '配列の数←固定長にしてるのめっちゃ怖い
Dim Buff As Variant
'range型確定なので先に宣言
Dim Cl As Range
Dim maxRow As Long

Range("E1").CurrentRegion.Select

'↓E列だけでよくない?あと48行目まで固定だと今後使い辛そう。最下行取って可変にしたほうがいいです
maxRow = Cells(Rows.Count, 36).End(xlUp).Offset(1, 0).Row - 1 '(最下行が非表示になってる可能性を考慮)
Set Buff = Range("E1:E" & maxRow).SpecialCells(xlCellTypeVisible) '★★★Range("E2:E" & maxRow)から修正

'よくみたらk初期化してへんやんけ!!!!!!---------------------------------------------------
Dim k As Long
k = 0
'-------------------------------------------------------------------------------------------
For Each Cl In Buff
'E列しか取得してないからIf分も不要
'ClはRangeオブジェクトだからvalueだけ記憶
d(k) = Cl.Value
k = k + 1
'やっぱ怖いから条件追加しとこ
If k > 99 Then Exit For
MsgBox Cl.Value '★★★配列には“部品コード”,”E000113”とはいっていた。

Next

Range("A2:AS" & maxRow).AutoFilter 'フィルタ解除

'上記の設定方法なら再設定しなくてもいいけど一応
maxRow = Cells(Rows.Count, 36).End(xlUp).Row

'キーはClじゃなくてd()ですよ
Range(Cells(1, 5), Cells(maxRow, 45)) _
.AutoFilter Field:=1, _
Criteria1:=d, _
Operator:=xlFilterValues

'Criteria1:=array(...)と同じ
End Sub

この初期化対応を記載いただく前のコードではE1から選択にかえても
実行時エラー91
オブジェクト変数またはwithブロック変数が設定されていません
とでてしまったので、とっても重要だったのですね…

で、あの、解決はしたものの、暫定版では配列の固定長問題を解決しようとしてくださっていますよね
私も知りたいのでこの問題も解決した状態になるのであればコード修正おねがいできますでしょうか。

自分でも解決版とドッキングさせて検討はつづけておりますが今の時点ではうまくいっておりません。
(いまはReDim d(UBound(Buff))で型が一致しないと怒られ中です）
よろしければ…。

[kumiko]

ありがとうございます！
確認しました。ばっちりでした。固定長の問題も解決いただきありがとうございます。
プラスアルファ勉強になりましたし、よりいいものになって本当によかったです。
これからじっくり確認していきたいと思いますがまずはお礼申し上げます。

[pig_vba]

補足ですが、今回は可読性優先で無視しましたが本来はReDim d(Buff.cells.Count-1)です。Rangeが１から始まることに対して配列は０から始まるからです。(Option Base [a]が定義されていた場合は[a]から始まりますが)間違って理解してしまわないように一応付け加えておきます。