[[20230207165504]] 『オートフィルタの抽出条件をリストから取得』(aoao) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『オートフィルタの抽出条件をリストから取得』(aoao)

参考サイト:https://ramq-cat.com/autofilter-multiple-conditions/

VBA初心者です。
オートフィルタの抽出条件が変動するため
抽出用のリストに記載されたものを抽出したいです。

上記のサイトを参考に作成したのですが、どうしても

    For Each c In varData

の部分で「型が一致しません(13)」のエラーが出てしまいます。
解決策をご存じの方がいれば、教えてほしいです。

< 使用 Excel:Microsoft365、使用 OS:Windows10 >


参考までに… (独学でVBAを触っているので見ずらいコードになっていたらすみません…)

 '-------------------------------空の辞書を作成する
    Dim myDic1 As Object, myKey1 As Variant
    Dim c1 As Variant, varData1 As Variant
    Set myDic1 = CreateObject("Scripting.Dictionary")

    Dim myDic2 As Object, myKey2 As Variant
    Dim c2 As Variant, varData2 As Variant
    Set myDic2 = CreateObject("Scripting.Dictionary")

    Dim myDic3 As Object, myKey3 As Variant
    Dim c3 As Variant, varData3 As Variant
    Set myDic3 = CreateObject("Scripting.Dictionary")

    '-------------------------------シート「リスト」のA列(2行目から最終行まで)を取り出す(varDataという箱に入れる)
    With Sheets("リスト")
       varData1 = .Range("L3", .Range("L" & Rows.Count).End(xlUp)).Value
       varData2 = .Range("M3", .Range("M" & Rows.Count).End(xlUp)).Value
       varData3 = .Range("N3", .Range("N" & Rows.Count).End(xlUp)).Value
    End With

   '-------------------------------取り出したリストそれぞれにおいて
    For Each c1 In varData1
       If Not c1 = Empty Then                   '空白でなく、
          If Not myDic1.Exists(c1) Then         'すでにmyDic1に存在しなければ(重複あるとエラーになるため)
             myDic1.Add c1, Null                'myDic1に追加する(myDicは連想配列)
          End If
       End If
    Next

    For Each c2 In varData2
       If Not c2 = Empty Then                   '空白でなく、
          If Not myDic2.Exists(c2) Then         'すでにmyDic2に存在しなければ(重複あるとエラーになるため)
             myDic2.Add c2, Null                'myDic2に追加する(myDicは連想配列)
          End If
       End If
    Next

    For Each c3 In varData3
       If Not c3 = Empty Then                   '空白でなく、
          If Not myDic3.Exists(c3) Then         'すでにmyDic3に存在しなければ(重複あるとエラーになるため)
             myDic3.Add c3, Null                'myDic3に追加する(myDicは連想配列)
          End If
       End If
    Next

   '-------------------------------各myDicからキーを取り出して配列にする
    myKey1 = myDic1.Keys
    myKey2 = myDic2.Keys
    myKey3 = myDic3.Keys

'-------------------------------------------オートフィルター

   '★条件1
     Rows("1:1").AutoFilter Field:=13, Criteria1:=myKey1, Operator:=xlFilterValues
    If WorksheetFunction.Subtotal(3, Range("BD:BD")) >= 1 Then  '結果が1以上なら下記の操作
     With Range("A1").CurrentRegion
         .Resize(.Rows.Count - 1).Offset(1, 0).Delete          '見出しを除いてフィルタ結果を削除
     End With
    End If
     Range("A1").AutoFilter                                    'オートフィルタ解除

   '★条件2
     Rows("1:1").AutoFilter Field:=1, Criteria1:=myKey2, Operator:=xlFilterValues
    If WorksheetFunction.Subtotal(3, Range("BD:BD")) >= 1 Then  '結果が1以上なら下記の操作
     With Range("A1").CurrentRegion
         .Resize(.Rows.Count - 1).Offset(1, 0).Delete          '見出しを除いてフィルタ結果を削除
     End With
    End If
     Range("A1").AutoFilter                                    'オートフィルタ解除

   '★条件3
     Rows("1:1").AutoFilter Field:=7, Criteria1:=myKey3, Operator:=xlFilterValues
    If WorksheetFunction.Subtotal(3, Range("BD:BD")) >= 1 Then  '結果が1以上なら下記の操作
     With Range("A1").CurrentRegion
         .Resize(.Rows.Count - 1).Offset(1, 0).Delete          '見出しを除いてフィルタ結果を削除
     End With
    End If
     Range("A1").AutoFilter                                    'オートフィルタ解除

     Rows("1:1").AutoFilter                                    'オートフィルタ設定

   '-------------------------------各myDicを空にする
    Set myDic1 = Nothing
    Set myDic2 = Nothing
    Set myDic3 = Nothing

(aoao) 2023/02/07(火) 17:05:20


抽出用のリストがA列の1行目から始まっているとか?
ならば2行目から始めてみて。

(通りすがり) 2023/02/07(火) 17:43:21


 >For Each c1 In varData1
 この部分のことですよね?

 見たところ、エラーの要素なさそうだけど・・・
 For Eachじゃなくて、i = 1 to ubound(配列,1) ではどうです?
 試してないけど、以下一例

    Option Explicit
    Sub test()
        Dim i As Long                'ループ用の変数
        Dim myRange(1 To 3) As Range 'Range型の配列を作り、対象範囲を格納する
        Dim ws As Worksheet
        Set ws = Sheets("リスト")
        With ws
           Set myRange(1) = .Range("L3", .Range("L" & Rows.Count).End(xlUp))
           Set myRange(2) = .Range("M3", .Range("M" & Rows.Count).End(xlUp))
           Set myRange(3) = .Range("N3", .Range("N" & Rows.Count).End(xlUp))
        End With
        For i = 1 To 3
            If MsgBox("対象範囲は" & myRange(i).Address(0, 0) & "です。想定通りですか?", vbYesNo) <> vbYes Then Exit Sub
            'デバッグが終わったら↑の行消してください
            Select Case i
            Case 1
                Call RowDelete(ws, 13, GetDictionaryKeys(myRange(i))) 'シートオブジェクト、オートフィルタのフィールド番号、フィルター用の配列を引数で渡す
            Case 2
                Call RowDelete(ws, 1, GetDictionaryKeys(myRange(i)))
            Case 3
                Call RowDelete(ws, 7, GetDictionaryKeys(myRange(i)))
            End Select
        Next i
        MsgBox "処理が完了しました"
    End Sub
    Function GetDictionaryKeys(myRng As Range) As Variant
        Dim w As Variant '配列用
        Dim i As Long    'ループ用変数
        w = myRng.Value  '設定した対象範囲を配列に入れる
        'DictionaryにKeyを追加していく
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(w, 1)
                .Item(w(i, 1)) = ""
            Next i
            GetDictionaryKeys = .keys '書き出し
        End With
    End Function
    Sub RowDelete(ws As Worksheet, fld As Long, v As Variant)
        With ws
            .Rows("1:1").AutoFilter fld, v, xlFilterValues
            If WorksheetFunction.Subtotal(3, .Range("BD:BD")) >= 1 Then  '結果が1以上なら下記の操作
                With .Range("A1").CurrentRegion
                    .Resize(.Rows.Count - 1).Offset(1, 0).Delete         '見出しを除いてフィルタ結果を削除
                End With
            End If
        End With
    End Sub
(稲葉) 2023/02/07(火) 18:57:36

 ごめん、一部見落とし
 >.Item(w(i, 1)) = ""
 ↑の部分を
 If w(i, 1) <> "" Then .Item(w(i, 1)) = ""
 こちらに置き換えてください。

(稲葉) 2023/02/07(火) 19:01:59


通りすがりさん
→抽出の条件として、「リスト」シートのL〜N列に記載されたものを指定したいです。
また、L1〜N2までは項目名などの見出しが設定されてるので、
厳密には3行目以降に記載されたもの(L3〜N3以降のそれぞれのデータ最終行)を、型に入れたつもりです。

稲葉さん
→解決策だけでなく添削まで、本当にありがとうございます!
仕事のパソコンからでしか該当のExcelにログインできないため、明日早速試してみます。
(aoao) 2023/02/07(火) 20:03:50


 >    myKey1 = myDic1.Keys
 >    myKey2 = myDic2.Keys
 >    myKey3 = myDic3.Keys

エラーと関係あるかわからないですけど、
別々にしたらまずくないですか?
1行がand条件のセットでは?
(まっつわん) 2023/02/07(火) 20:39:00


 >厳密には3行目以降に記載されたもの(L3〜N3以降のそれぞれのデータ最終行)を、型に入れたつもりです。

 Sub test()
    With Sheets("リスト")
       varData1 = .Range("L3", .Range("L" & Rows.Count).End(xlUp)).Value
                            '  ↑ が ↓ だったら
       varData1 = .Range("L3", .Range("L3")).Value
    End With

    For Each c1 In varData1             '実行時エラー'13' 型が一致しません。
    Next
    For i = 1 To UBound(varData1, 1)    'も実行時エラー'13' 型が一致しません。
    Next i
 End Sub

注意しましょう。
(kazuo) 2023/02/07(火) 23:25:41


 あ、提示したコード実行しないでください!
 リストシートとオートフィルタのシートが異なるのですね
 RowDelete(ws, 13, GetDictionaryKeys(myRange(i))) 
 RowDelete(Sheets("フィルタシート"), 13, GetDictionaryKeys(myRange(i))) 
 に変更してください
 kazuoさんに指摘いただいたところも、後程直します

 >別々にしたらまずくないですか?
 >1行がand条件のセットでは?
 それぞれ別の用件で、集計結果が1以上なら削除では?
 本人に聞かないとわからないですが。

 kazuoさんありがとうございました

(稲葉) 2023/02/08(水) 05:50:10


確認ですが、【オートフィルタ】で抽出するんですよね?
キーが重複してもエラーにならないので連想配列で重複を排除する必要なかったりしません?

むしろ気になるのは、既に指摘されている部分にもなりますが↓が3以下(1行のみor0行)になる可能性はないのでしょうか?

 .Range("L" & Rows.Count).End(xlUp).Row
 .Range("M" & Rows.Count).End(xlUp).Row
 .Range("N" & Rows.Count).End(xlUp).Row

(もこな2) 2023/02/08(水) 08:00:46


 AutoFilter解除し忘れてました・・・
 あとほかの方からも指摘あった点修正です。

 もこな2さんの
 >キーが重複してもエラーにならないので連想配列で重複を排除する必要なかったりしません?
 これは元データに空白があるかもしれないので、「配列作るの簡単だし」このままのほうがいいかも?

    Sub test2()
        Dim i As Long                'ループ用の変数
        Dim myRange(1 To 3) As Range 'Range型の配列を作り、対象範囲を格納する
        Dim wsList As Worksheet
        Dim wsFilter As Worksheet
        Set wsList = Sheets("リスト")
        Set wsFilter = Sheets("フィルター") '★フィルタをするシートを指定
        With wsList
           Set myRange(1) = Intersect(.Range("L3", .Range("L" & Rows.Count).End(xlUp)), .Range("L3:L" & Rows.Count)) '★必ず3行目以降が対象範囲になるように→Intersect
           Set myRange(2) = Intersect(.Range("M3", .Range("M" & Rows.Count).End(xlUp)), .Range("M3:M" & Rows.Count))
           Set myRange(3) = Intersect(.Range("N3", .Range("N" & Rows.Count).End(xlUp)), .Range("N3:N" & Rows.Count))
        End With
        For i = 1 To 3
            If MsgBox("対象範囲は" & myRange(i).Address(0, 0) & "です。想定通りですか?", vbYesNo) <> vbYes Then Exit Sub
            'デバッグが終わったら↑の行消してください
            Select Case i
            Case 1
                Call RowDelete(wsFilter, 13, GetDictionaryKeys(myRange(i))) 'シートオブジェクト、オートフィルタのフィールド番号、フィルター用の配列を引数で渡す
            Case 2
                Call RowDelete(wsFilter, 1, GetDictionaryKeys(myRange(i)))
            Case 3
                Call RowDelete(wsFilter, 7, GetDictionaryKeys(myRange(i)))
            End Select
        Next i
        MsgBox "処理が完了しました"
    End Sub
    Function GetDictionaryKeys(myRng As Range) As Variant
        Dim w As Variant '配列用
        Dim i As Long    'ループ用変数
        w = myRng.Resize(myRng.Rows.Count + 1).Value '★1セルにならないように、範囲を+1してから配列に渡す
        'DictionaryにKeyを追加していく
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(w, 1)
                If w(i, 1) <> "" Then
                    .Item(CStr(w(i, 1))) = ""        '★数字の場合、AutoFilterのxlFilterValuesでフィルターされないため、String型に変換してからKeyに追加
                End If
            Next i
            GetDictionaryKeys = .keys                '書き出し
        End With
    End Function
    Sub RowDelete(ws As Worksheet, fld As Long, v As Variant)
        If UBound(v) > 0 Then '★対象があれば、フィルタ実行
            With ws
                If .AutoFilterMode = True Then .AutoFilterMode = False
                .Rows("1:1").AutoFilter fld, v, xlFilterValues               'フィルタをかけたい列の先頭が数値だと、
                If WorksheetFunction.Subtotal(3, .Range("BD:BD")) >= 1 Then  '結果が1以上なら下記の操作
                    With .Range("A1").CurrentRegion
'                        Application.DisplayAlerts = False
                        .Resize(.Rows.Count - 1).Offset(1, 0).Delete         '見出しを除いてフィルタ結果を削除
'                        Application.DisplayAlerts = True
                    End With
                End If
                .AutoFilterMode = False
            End With
        End If
    End Sub
(稲葉) 2023/02/08(水) 08:53:20

  >これは元データに空白があるかもしれないので、「配列作るの簡単だし」
 Criteria用に一次元配列が作れればいいのであれば、365だしWorkSheetFunctionで
 TRANSPOSE(UNIQUE(リスト範囲)) でいいかもしれません。
 (UNIQUEする必要もないかも)

 ちなみに、抽出用のリストに空白セルがあったとき
 空白セルがEmptyだとAutoFilterの抽出結果になんの影響の無いようです
 AutoFilterで空白セルを抽出したいときは、Emptyじゃなくて "" を指定しないといけないようです。
(´・ω・`) 2023/02/08(水) 09:20:49

みなさん

すみません、ご指摘や再構築と何からなにまで本当にありがとうございます…

・「リスト」シートのL、M、N列はそれぞれ別の条件で、フィルタで抽出する場所も異なります。
・上記の条件は不定期に変動し、元データに空白がある可能性もあります。

参考にと記載したマクロは一部抜粋したもので、前後にもコードがあったのですが
載せられない情報等もあったため、
そちらだけを伏せたフルバージョンを再度掲載いたします。

皆さんからの今までのご意見を参考に、初めて見るコードは調べていきながら
下記のものを修正したいと思います。

Sub テスト3()

'-------------------------------------------プロパティメッセージ非表示

    Application.DisplayAlerts = False

'-------------------------------------------

    Dim FolderPath As Variant, _
        FileName As Variant, _
        FilePath As Variant, _
        LedgeFileName As Variant, _
        MacroFileName As Variant

        FolderPath = ThisWorkbook.Path                                     'フォルダパス このマクロが保存されているフォルダ
        FileName = Dir(ThisWorkbook.Path & "\ダウンロード*")   'ファイル名  上記フォルダ内の「ダウンロードxlsx」
        FilePath = FolderPath & "\" & FileName                             'ファイルパス 上記のフルパス
        LedgerFileName = "台帳.xlsx"
        MacroFileName = "マクロ.xlsm"

'-------------------------------------------別ブック操作:開く

    Workbooks.Open FileName:=FilePath

'-------------------------------------------別ブック操作:シート名変更

    Workbooks(FileName).Worksheets("ダウンロード").Name = "原本"

'-------------------------------------------別ブック操作:同ブック間でシートを複製、シート名変更:「原本」⇒「新規」

    Workbooks(FileName).Worksheets("原本").Copy Before:=Workbooks(FileName).Worksheets("原本")
    ActiveSheet.Name = "新規"

'-------------------------------------------別ブック操作:別ブック間でシート複製

    Dim wsA As Worksheet
    Set wsA = Workbooks(MacroFileName).Worksheets("リスト")    '当ブック
    Dim wsB As Worksheet
    Set wsB = Workbooks(FileName).Worksheets("新規")           '別ブック

    wsA.Copy after:=wsB

'-------------------------------------------別ブック操作:転記:「リスト」シートから「新規」シートへ (同ブック間操作)

    wsB.Activate
    Sheets("リスト").Range("AA1:AF2").Copy Sheets("新規").Range("BE1:BJ2")

'-------------------------------------------別ブック操作:データの入力規則

    With Range("BE2").Validation  '対応者
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=OFFSET(リスト!$H$2,0,0,COUNTA(リスト!$H:$H)-1,1)"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = False
    End With

    Range("BF2").NumberFormatLocal = "yyyy/mm/dd"  '完了日

    With Range("BG2").Validation  '結果
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=OFFSET(リスト!$I$2,0,0,COUNTA(リスト!$I:$I)-1,1)"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = False
    End With

    With Range("BH2").Validation  '現在の状況
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=OFFSET(リスト!$J$2,0,0,COUNTA(リスト!$J:$J)-1,1)"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = False
    End With

    With Range("BI2").Validation  '備考
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=OFFSET(リスト!$K$2,0,0,COUNTA(リスト!$K:$K)-1,1)"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = False
    End With

'-------------------------------------------別ブック操作:関数設定

    wsB.Select
    Range("BD2").Formula = "=VLOOKUP($X:$X,'" & FolderPath & "\[" & LedgerFileName & "]全て'!$F:$I,4,0)"

'-------------------------------------------別ブック操作:関数反映:(データが入力されている行の一番下まで)

    Range("BD2:BJ2").Copy
    Range("BD2:BJ" & Range("X" & Cells.Rows.Count).End(xlUp).Row).Select
    ActiveSheet.Paste

'-------------------------------------------別ブック操作:値貼り:関数の値固定

    Columns("BD:BD").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues

'-------------------------------------------別ブック操作:並び替え

    With wsB.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("M1"), Order:=xlAscending    'コード
        .SortFields.Add Key:=Range("R1"), Order:=xlAscending, CustomOrder:="OK,NG,-"  '状況
        .SortFields.Add Key:=Range("S1"), Order:=xlAscending    '申請年月日
        .SetRange Range("A1:BK" & Range("X" & Cells.Rows.Count).End(xlUp).Row)
        .Header = xlYes
        .Apply
    End With

'-------------------------------------------別ブック操作:関数設定

    Range("BD1").Formula = "=SUBTOTAL(103,$X:$X)-1"

'-------------------------------------------別ブック操作:体裁調整:1行目中央上揃え、折り返して全体表示、高さ変更

    With Rows("1:1")
        .VerticalAlignment = xlTop
        .HorizontalAlignment = xlCenter
        .WrapText = True
        .RowHeight = 40
    End With

'-------------------------------------------別ブック操作:列の幅

    Columns("R:R").ColumnWidth = 15
    Columns("S:S").ColumnWidth = 11
    Columns("Y:Y").ColumnWidth = 15
    Columns("BF:BF").ColumnWidth = 11

  '-------------------------------別ブック操作:空の辞書を作成する
    Dim myDic1 As Object, myKey1 As Variant
    Dim c1 As Variant, varData1 As Variant
    Set myDic1 = CreateObject("Scripting.Dictionary")

    Dim myDic2 As Object, myKey2 As Variant
    Dim c2 As Variant, varData2 As Variant
    Set myDic2 = CreateObject("Scripting.Dictionary")

    Dim myDic3 As Object, myKey3 As Variant
    Dim c3 As Variant, varData3 As Variant
    Set myDic3 = CreateObject("Scripting.Dictionary")

    '-------------------------------別ブック操作:「リスト」シートのL列、M列、N列の各3行目から最終行まで取得(varDataという箱に入れる)
    With Sheets("リスト")
       varData1 = .Range("L3", .Range("L" & Rows.Count).End(xlUp)).Value  '対象外コード1
       varData2 = .Range("M3", .Range("M" & Rows.Count).End(xlUp)).Value  '対象外コード2
       varData3 = .Range("N3", .Range("N" & Rows.Count).End(xlUp)).Value  '対象外コード3
    End With

   '-------------------------------別ブック操作:取得したリストそれぞれにおいて下記操作
    For Each c1 In varData1
       If Not c1 = Empty Then                   '空白でなく、
          If Not myDic1.Exists(c1) Then         'すでにmyDic1に存在しなければ(重複あるとエラーになるため)
             myDic1.Add c1, Null                'myDic1に追加する(myDicは連想配列)
          End If
       End If
    Next

    For Each c2 In varData2
       If Not c2 = Empty Then                   '空白でなく、
          If Not myDic2.Exists(c2) Then         'すでにmyDic2に存在しなければ(重複あるとエラーになるため)
             myDic2.Add c2, Null                'myDic2に追加する(myDicは連想配列)
          End If
       End If
    Next

    For Each c3 In varData3
       If Not c3 = Empty Then                   '空白でなく、
          If Not myDic3.Exists(c3) Then         'すでにmyDic3に存在しなければ(重複あるとエラーになるため)
             myDic3.Add c3, Null                'myDic3に追加する(myDicは連想配列)
          End If
       End If
    Next

   '-------------------------------別ブック操作:各myDicからキーを取り出して配列にする
    myKey1 = myDic1.keys
    myKey2 = myDic2.keys
    myKey3 = myDic3.keys

'-------------------------------------------別ブック操作:「新規」シートにてオートフィルタ

    Dim d As String
    d = wsA.Range("D1")   '当ブックから当月条件を取得

   '★条件1:-、NG以外
    Rows("1:1").AutoFilter Field:=18, Criteria1:="<>-", Operator:=xlAnd, Criteria2:="<>NG"
    If WorksheetFunction.Subtotal(3, Range("R:R")) >= 1 Then    '結果が1以上なら下記の操作
     With Range("A1").CurrentRegion
         .Resize(.Rows.Count - 1).Offset(1, 0).Delete          '見出しを除いてフィルタ結果を削除
     End With
    End If
     Range("A1").AutoFilter                                    'オートフィルタ解除

   '★条件2:当月以外
    Rows("1:1").AutoFilter Field:=23, Criteria1:=d
    If WorksheetFunction.Subtotal(3, Range("W:W")) >= 1 Then    '結果が1以上なら下記の操作
     With Range("A1").CurrentRegion
         .Resize(.Rows.Count - 1).Offset(1, 0).Delete          '見出しを除いてフィルタ結果を削除
     End With
    End If
     Range("A1").AutoFilter                                    'オートフィルタ解除

   '★条件3:#N/A以外
     Rows("1:1").AutoFilter Field:=56, Criteria1:="<>#N/A"
    If WorksheetFunction.Subtotal(3, Range("BD:BD")) >= 1 Then  '結果が1以上なら下記の操作
     With Range("A1").CurrentRegion
         .Resize(.Rows.Count - 1).Offset(1, 0).Delete          '見出しを除いてフィルタ結果を削除
     End With
    End If
     Range("A1").AutoFilter                                    'オートフィルタ解除

   '★条件4:対象外コード1
     Rows("1:1").AutoFilter Field:=13, Criteria1:=myKey1, Operator:=xlFilterValues
    If WorksheetFunction.Subtotal(3, Range("BD:BD")) >= 1 Then  '結果が1以上なら下記の操作
     With Range("A1").CurrentRegion
         .Resize(.Rows.Count - 1).Offset(1, 0).Delete          '見出しを除いてフィルタ結果を削除
     End With
    End If
     Range("A1").AutoFilter                                    'オートフィルタ解除

   '★条件5:対象外CD2
     Rows("1:1").AutoFilter Field:=1, Criteria1:=myKey2, Operator:=xlFilterValues
    If WorksheetFunction.Subtotal(3, Range("BD:BD")) >= 1 Then  '結果が1以上なら下記の操作
     With Range("A1").CurrentRegion
         .Resize(.Rows.Count - 1).Offset(1, 0).Delete          '見出しを除いてフィルタ結果を削除
     End With
    End If
     Range("A1").AutoFilter                                    'オートフィルタ解除

   '★条件6:対象外コード3
     Rows("1:1").AutoFilter Field:=7, Criteria1:=myKey3, Operator:=xlFilterValues
    If WorksheetFunction.Subtotal(3, Range("BD:BD")) >= 1 Then  '結果が1以上なら下記の操作
     With Range("A1").CurrentRegion
         .Resize(.Rows.Count - 1).Offset(1, 0).Delete          '見出しを除いてフィルタ結果を削除
     End With
    End If
     Range("A1").AutoFilter                                    'オートフィルタ解除

     Rows("1:1").AutoFilter                                    'オートフィルタ設定

   '-------------------------------別ブック操作:各myDicを空にする
    Set myDic1 = Nothing
    Set myDic2 = Nothing
    Set myDic3 = Nothing

'-------------------------------------------別ブック操作:非表示

    Columns("A:F").Hidden = True
    Columns("H:L").Hidden = True
    Columns("N:Q").Hidden = True
    Columns("T:V").Hidden = True
    Columns("Z:BC").Hidden = True

'-------------------------------------------別ブック操作:シート名変更

    Worksheets("新規").Name = Format(Now, "mmdd-hh時")

'-------------------------------------------別ブック操作:カーソル設定

    Range("G1").Select

'-------------------------------------------別ブック操作:上書き保存して閉じる

    Workbooks(FileName).Close SaveChanges:=True

'-------------------------------------------プロパティメッセージ表示

    Application.DisplayAlerts = True

'-------------------------------------------メッセージボックス

    MsgBox "完了"

End Sub

(aoao) 2023/02/08(水) 11:06:40


 >  ちなみに、抽出用のリストに空白セルがあったとき
 >空白セルがEmptyだとAutoFilterの抽出結果になんの影響の無いようです
 勉強になります。
 空白が途中にあるってことは式の結果が空白の可能性も捨てきれなかったので、
 やはり評価したほうが良い気がしたんですが、必要ないですかね。

(稲葉) 2023/02/08(水) 11:24:10


 >空白が途中にあるってことは式の結果が空白の可能性
 なるほど、そういうこともあり得ますね
 その場合、空白を抽出したいということもあるかも知れません
 データ次第でもあり、要求仕様次第でもあり
(´・ω・`) 2023/02/08(水) 11:36:40

 >空白を抽出したいということもあるかも知れません
 ですね。
 要するに、コード見ただけじゃわからんから、元データと期待する結果を見ない限り
 私たちでお手伝いできるところは限定的ですね・・・

 ついでに伺いたいのですが、コード中に注釈で書いた
 >★数字の場合、AutoFilterのxlFilterValuesでフィルターされないため、String型に変換してからKeyに追加
 この部分も、TRANSPOSEのままだと数値として取り込みそうなので、やはり
 > データ次第でもあり、要求仕様次第でもあり
 に尽きますね。

 この認識だけ間違ってないかご指摘くださいますと助かります。

(稲葉) 2023/02/08(水) 11:41:25


空白のお話が少々理解できていないのですが、

<ケース1>
10000
10001
10002
(空白)
(空白)
....

のようなことですか?それとも

<ケース2>
10000
10001
(空白)
10002
(空白)
(空白)
....

上記のように、間に空白を挟む場合のことですか?

・空白を抽出はしないです。(<ケース1>を想定)
・L3〜N3以降に記載される条件は数字になります。

思っていた回答になっていなかったら申し訳ございません。
(aoao) 2023/02/08(水) 12:42:22


今回こちらでお聞きした意図としては、
★条件4〜★条件6の「Criteria」に入れたい抽出条件が可変するため
「別シートの特定の列に記載されたもの※」を抽出条件として設定したい
という事になります。

※データが入力されている最終行まで=空白以外
(aoao) 2023/02/08(水) 12:51:18


 <ケース2>
 10000
 10001
 ""      =IFERROR(式,"")などの、数式として空白に見えているセル
 10002
 (空白)
 (空白)

 を指していました。

 >・L3〜N3以降に記載される条件は数字になります。
 であれば、配列に取り込むときは安全を見て下記の通しString型(CStr)に
 変換したほうがいいかと思います。
 >.Item(CStr(w(i, 1))) = ""        '★数字の場合、AutoFilterのxlFilterValuesでフィルターされないため、String型に変換してからKeyに追加

(稲葉) 2023/02/08(水) 13:23:06


下記で修正しましたが、うまく実行できません(何故か新たに標準モジュールが追加されてマクロが止まります。)
解決方法があれば教えていただきたいです。

Sub テスト3()

'-------------------------------------------プロパティメッセージ非表示

    Application.DisplayAlerts = False

……
  〜省略〜  (aoao) 2023/02/08(水) 11:06:40 と同様
……

    Columns("BF:BF").ColumnWidth = 11

'以下変更部分

        Dim i As Long                'ループ用の変数
        Dim myRange(1 To 3) As Range 'Range型の配列を作り、対象範囲を格納する
        Dim wsList As Worksheet
        Dim wsFilter As Worksheet
        Set wsList = Sheets("リスト")
        Set wsFilter = Sheets("新規")

        With wsList
           Set myRange(1) = Intersect(.Range("L3", .Range("L" & Rows.Count).End(xlUp)), .Range("L3:L" & Rows.Count)) '★必ず3行目以降が対象範囲になるように→Intersect
           Set myRange(2) = Intersect(.Range("M3", .Range("M" & Rows.Count).End(xlUp)), .Range("M3:M" & Rows.Count))
           Set myRange(3) = Intersect(.Range("N3", .Range("N" & Rows.Count).End(xlUp)), .Range("N3:N" & Rows.Count))
        End With

        For i = 1 To 3
            Select Case i
            Case 1
                Call RowDelete(wsFilter, 13, GetDictionaryKeys(myRange(i))) 'シートオブジェクト、オートフィルタのフィールド番号、フィルター用の配列を引数で渡す
            Case 2
                Call RowDelete(wsFilter, 1, GetDictionaryKeys(myRange(i)))
            Case 3
                Call RowDelete(wsFilter, 7, GetDictionaryKeys(myRange(i)))
            End Select
        Next i

        MsgBox "処理が完了しました"
    End Sub

    Function GetDictionaryKeys(myRng As Range) As Variant
        Dim w As Variant '配列用
        Dim i As Long    'ループ用変数

        w = myRng.Resize(myRng.Rows.Count + 1).Value '★1セルにならないように、範囲を+1してから配列に渡す

        'DictionaryにKeyを追加していく
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(w, 1)
                If w(i, 1) <> "" Then
                    .Item(CStr(w(i, 1))) = ""        '★数字の場合、AutoFilterのxlFilterValuesでフィルターされないため、String型に変換してからKeyに追加
                End If
            Next i
            GetDictionaryKeys = .keys                '書き出し
        End With

    End Function

    Sub RowDelete(ws As Worksheet, fld As Long, v As Variant)

    '-------------------------------------------別ブック操作:「新規」シートにてオートフィルタ
    Dim d As String
    Set d = wsA.Range("D1")   '当ブックの「リスト」シートのセル値から条件を取得(条件2で使用)

   '★条件1
     Rows("1:1").AutoFilter Field:=13, Criteria1:=myKey1, Operator:=xlFilterValues
    If WorksheetFunction.Subtotal(3, Range("BD:BD")) >= 1 Then  '結果が1以上なら下記の操作
     With Range("A1").CurrentRegion
         .Resize(.Rows.Count - 1).Offset(1, 0).Delete          '見出しを除いてフィルタ結果を削除
     End With
    End If
     Range("A1").AutoFilter                                    'オートフィルタ解除

   '★条件2
     Rows("1:1").AutoFilter Field:=1, Criteria1:=myKey2, Operator:=xlFilterValues
    If WorksheetFunction.Subtotal(3, Range("BD:BD")) >= 1 Then  '結果が1以上なら下記の操作
     With Range("A1").CurrentRegion
         .Resize(.Rows.Count - 1).Offset(1, 0).Delete          '見出しを除いてフィルタ結果を削除
     End With
    End If
     Range("A1").AutoFilter                                    'オートフィルタ解除

   '★条件3
     Rows("1:1").AutoFilter Field:=7, Criteria1:=myKey3, Operator:=xlFilterValues
    If WorksheetFunction.Subtotal(3, Range("BD:BD")) >= 1 Then  '結果が1以上なら下記の操作
     With Range("A1").CurrentRegion
         .Resize(.Rows.Count - 1).Offset(1, 0).Delete          '見出しを除いてフィルタ結果を削除
     End With
    End If
     Range("A1").AutoFilter                                    'オートフィルタ解除

    If UBound(v) > 0 Then '★対象があれば、フィルタ実行
        With ws
            If .AutoFilterMode = True Then .AutoFilterMode = False
            .Rows("1:1").AutoFilter fld, v, xlFilterValues               'フィルタをかけたい列の先頭が数値だと、
            If WorksheetFunction.Subtotal(3, .Range("BD:BD")) >= 1 Then  '結果が1以上なら下記の操作
                With .Range("A1").CurrentRegion
'                     Application.DisplayAlerts = False
                     .Resize(.Rows.Count - 1).Offset(1, 0).Delete         '見出しを除いてフィルタ結果を削除
'                     Application.DisplayAlerts = True
                End With
            End If
            .AutoFilterMode = False
        End With
    End If

'変更部分終了

'-------------------------------------------別ブック操作:非表示

    Columns("A:F").Hidden = True

……
  〜省略〜  (aoao) 2023/02/08(水) 11:06:40 と同様
……

    MsgBox "完了"

End Sub

(aoao) 2023/02/08(水) 14:24:44


★条件1〜★条件3の部分記載誤りです。
正しくは下記です

  '★条件1:-、NG以外
    Rows("1:1").AutoFilter Field:=18, Criteria1:="<>-", Operator:=xlAnd, Criteria2:="<>NG"
    If WorksheetFunction.Subtotal(3, Range("R:R")) >= 1 Then    '結果が1以上なら下記の操作
     With Range("A1").CurrentRegion
         .Resize(.Rows.Count - 1).Offset(1, 0).Delete          '見出しを除いてフィルタ結果を削除
     End With
    End If
     Range("A1").AutoFilter                                    'オートフィルタ解除
   '★条件2:当月以外
    Rows("1:1").AutoFilter Field:=23, Criteria1:=d
    If WorksheetFunction.Subtotal(3, Range("W:W")) >= 1 Then    '結果が1以上なら下記の操作
     With Range("A1").CurrentRegion
         .Resize(.Rows.Count - 1).Offset(1, 0).Delete          '見出しを除いてフィルタ結果を削除
     End With
    End If
     Range("A1").AutoFilter                                    'オートフィルタ解除
   '★条件3:#N/A以外
     Rows("1:1").AutoFilter Field:=56, Criteria1:="<>#N/A"
    If WorksheetFunction.Subtotal(3, Range("BD:BD")) >= 1 Then  '結果が1以上なら下記の操作
     With Range("A1").CurrentRegion
         .Resize(.Rows.Count - 1).Offset(1, 0).Delete          '見出しを除いてフィルタ結果を削除
     End With
    End If
     Range("A1").AutoFilter                                    'オートフィルタ解除
(aoao) 2023/02/08(水) 14:28:42

 いやー・・・
 初耳な条件が多すぎる
 >(aoao) 2023/02/08(水) 14:28:42
 で提示した条件1〜3は、コードを見る限り、Deleteしているから、一回しか実行しなくてよさそうだけど
 どうですか?

 以下の認識で間違いないか教えてください。
 A〜Fをフィルターするときに、
 A列を条件1 削除 フィルター解除
 B列を条件2 削除 フィルター解除
 C列を条件3 削除 フィルター解除
 D列をリストL列で絞り込んで  削除 フィルター解除
 E列をリストM列で絞り込んで  削除 フィルター解除
 D列をリストN列で絞り込んで  削除 フィルター解除
 という手順でいいのかな?

 ほかにも突っ込みたいところたくさんあるけど・・・
(稲葉) 2023/02/08(水) 14:41:59

 取り急ぎ整頓したけど、全体像見えてないのと、実際のデータがないとこれ以上は無理・・・

    Sub テスト3()
        '-------------------------------------------プロパティメッセージ非表示
            Application.DisplayAlerts = False 'DisplayAlertは先頭に持ってこないほうがいい。必要な場所で最小限の範囲で実施すべき。
        '……
        '  〜省略〜  (aoao) 2023/02/08(水) 11:06:40 と同様
        '……
            Columns("BF:BF").ColumnWidth = 11
        '以下変更部分
        Dim i As Long                'ループ用の変数
        Dim myRange(1 To 3) As Range 'Range型の配列を作り、対象範囲を格納する
        Dim wsList As Worksheet
        Dim wsFilter As Worksheet
        Dim d As String
        Dim wsf As WorksheetFunction: Set wsf = Application.WorksheetFunction
        Set wsList = Sheets("リスト")
        Set wsFilter = Sheets("新規")

        '固定フィルタ条件・削除
        d = wsList.Range("D1").Value
        With wsFilter
            '★条件1:-、NG以外
            .Rows("1:1").AutoFilter Field:=18, Criteria1:="<>-", Operator:=xlAnd, Criteria2:="<>NG"
            Call DeleteOnly(wsFilter, .[R1]) 'サブプロシジャで処理
            .AutoFilterMode = False

            '★条件2:当月以外
            .Rows("1:1").AutoFilter Field:=23, Criteria1:=d
            Call DeleteOnly(wsFilter, .[W1])
            .AutoFilterMode = False

            '★条件3:#N/A以外
            .Rows("1:1").AutoFilter Field:=56, Criteria1:="<>#N/A"
            Call DeleteOnly(wsFilter, .[BD1])
            .AutoFilterMode = False
        End With

        '可変フィルタ条件設定・削除
        With wsList
           Set myRange(1) = Intersect(.Range("L3", .Range("L" & Rows.Count).End(xlUp)), .Range("L3:L" & Rows.Count)) '★必ず3行目以降が対象範囲になるように→Intersect
           Set myRange(2) = Intersect(.Range("M3", .Range("M" & Rows.Count).End(xlUp)), .Range("M3:M" & Rows.Count))
           Set myRange(3) = Intersect(.Range("N3", .Range("N" & Rows.Count).End(xlUp)), .Range("N3:N" & Rows.Count))
        End With
        For i = 1 To 3
            Select Case i
            Case 1
                Call RowDelete(wsFilter, 13, GetDictionaryKeys(myRange(i))) 'シートオブジェクト、オートフィルタのフィールド番号、フィルター用の配列を引数で渡す
            Case 2
                Call RowDelete(wsFilter, 1, GetDictionaryKeys(myRange(i)))
            Case 3
                Call RowDelete(wsFilter, 7, GetDictionaryKeys(myRange(i)))
            End Select
        Next i
        '別ブック?の操作はメインモジュールに
        '変更部分終了
        '-------------------------------------------別ブック操作:非表示
            Columns("A:F").Hidden = True
        '……
        '  〜省略〜  (aoao) 2023/02/08(水) 11:06:40 と同様
        '……
            MsgBox "完了"

        MsgBox "処理が完了しました"
    End Sub
    Function GetDictionaryKeys(myRng As Range) As Variant
        Dim w As Variant '配列用
        Dim i As Long    'ループ用変数
        w = myRng.Resize(myRng.Rows.Count + 1).Value '★1セルにならないように、範囲を+1してから配列に渡す
        'DictionaryにKeyを追加していく
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(w, 1)
                If w(i, 1) <> "" Then
                    .Item(CStr(w(i, 1))) = ""        '★数字の場合、AutoFilterのxlFilterValuesでフィルターされないため、String型に変換してからKeyに追加
                End If
            Next i
            GetDictionaryKeys = .keys                '書き出し
        End With
    End Function
    Sub RowDelete(ws As Worksheet, fld As Long, v As Variant)
        If UBound(v) > 0 Then '★対象があれば、フィルタ実行
            With ws
                If .AutoFilterMode = True Then .AutoFilterMode = False
                .Rows("1:1").AutoFilter fld, v, xlFilterValues               'フィルタをかけたい列の先頭が数値だと、
                Call DeleteOnly(ws, .[BD1])
                .AutoFilterMode = False
            End With
        End If
    End Sub
    Sub DeleteOnly(ws As Worksheet, r As Range)
        If WorksheetFunction.Subtotal(3, r.EntireColumn) >= 1 Then
            With ws.Range("A1").CurrentRegion
                Application.DisplayAlerts = False
                    .Resize(.Rows.Count - 1).Offset(1, 0).Delete         '見出しを除いてフィルタ結果を削除
                Application.DisplayAlerts = True
            End With
        End If
    End Sub

(稲葉) 2023/02/08(水) 15:07:37


 やっていることはデータのクリーニングですよね
 フィルターしてヒットした行は削除

 これって、パワークエリの得意分野だとおもいますが、どうでしょう
 VBAの練習ですっていうなら、それはそれでいいですけど
(´・ω・`) 2023/02/08(水) 15:25:37

稲葉さん
→提供頂いたコードで出来ました!
 本当にすごいです、ありがとうございます!!
 ひとつの標準モジュールでSub〜End Subは1個しか指定できないと思っていたのですが
 稲葉さんが記載してくださったFunctionの使い方を調べて
 プロシージャというものを初めて知り、
 そこからいろいろ学ばせていただきました。

(´・ω・`)さん
→VBAの練習ではないのです。
 パワークエリというものを今初めて知ったので、次回から参考にさせていただきます。

後からポロポロと情報を小出しにしてすみませんご迷惑おかけしました。
みなさん本当にありがとうございます。
すっごく助かりました。
(aoao) 2023/02/08(水) 16:54:39


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.