[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『オートフィルタの抽出条件をリストから取得』（aoao）
参考サイト：https://ramq-cat.com/autofilter-multiple-conditions/
VBA初心者です。
オートフィルタの抽出条件が変動するため
抽出用のリストに記載されたものを抽出したいです。
上記のサイトを参考に作成したのですが、どうしても
For Each c In varData
の部分で「型が一致しません（13）」のエラーが出てしまいます。
解決策をご存じの方がいれば、教えてほしいです。
＜ 使用 Excel：Microsoft365、使用 OS：Windows10 ＞
'-------------------------------空の辞書を作成する
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
（通りすがり） 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
稲葉さん
→解決策だけでなく添削まで、本当にありがとうございます！
仕事のパソコンからでしか該当の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行のみor０行）になる可能性はないのでしょうか？
.Range("L" & Rows.Count).End(xlUp).Row
.Range("M" & Rows.Count).End(xlUp).Row
.Range("N" & Rows.Count).End(xlUp).Row
（もこな２） 2023/02/08(水) 08:00:46
AutoFilter解除し忘れてました・・・ あとほかの方からも指摘あった点修正です。
もこな２さんの ＞キーが重複してもエラーにならないので連想配列で重複を排除する必要なかったりしません？ これは元データに空白があるかもしれないので、「配列作るの簡単だし」このままのほうがいいかも？
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)) '★必ず３行目以降が対象範囲になるように→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
※データが入力されている最終行まで＝空白以外
（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)) '★必ず３行目以降が対象範囲になるように→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：-、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)) '★必ず３行目以降が対象範囲になるように→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
（´・ω・`）さん
→VBAの練習ではないのです。
パワークエリというものを今初めて知ったので、次回から参考にさせていただきます。
後からポロポロと情報を小出しにしてすみませんご迷惑おかけしました。
みなさん本当にありがとうございます。
すっごく助かりました。
（aoao） 2023/02/08(水) 16:54:39
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.