Results of 1 - 1 of about 4265 for オートフィルタ (0.004 sec.)
- [[20230207165504]]
- #score: 4241
- @digest: b0fa9f43d8ffe76a772e9dc5eb760b79
- @id: 93454
- @mdate: 2023-02-08T07:54:39Z
- @size: 39526
- @type: text/plain
- #keywords: getdictionarykeys (164962), wsfilter (134062), rowdelete (127933), ク操 (117664), 作: (105410), mydic3 (75035), 作wi (74263), vardata1 (73445), タ結 (48236), mydic2 (46665), mydic1 (44318), xlfiltervalues (32887), タ解 (28690), 除en (27049), myrange (22736), autofilter (18586), 別ブ (17639), operator (13315), subtotal (11598), ルタ (10519), フィ (9274), autofiltermode (9184), criteria1 (8660), ィル (8381), 操作 (7845), 象範 (7724), worksheetfunction (6302), field (5913), variant (5839), rows (5700), ト") (5546), トフ (5407)
- 『オートフィルタの抽出条件をリストから取得』（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... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/202302/20230207165504.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 96996 documents and 607817 words.
訪問者：