Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1609 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【73145】複数条件の検索抽出 M_GUCHI 12/11/20(火) 16:53 質問[未読]
【73146】Re:複数条件の検索抽出 UO3 12/11/20(火) 17:34 発言[未読]
【73147】Re:複数条件の検索抽出 m_guchi 12/11/20(火) 21:46 発言[未読]
【73148】Re:複数条件の検索抽出 UO3 12/11/21(水) 6:14 発言[未読]
【73149】Re:複数条件の検索抽出 UO3 12/11/21(水) 6:16 発言[未読]
【73150】Re:複数条件の検索抽出 M_GUCHI 12/11/21(水) 10:22 回答[未読]
【73151】Re:複数条件の検索抽出 UO3 12/11/21(水) 11:19 発言[未読]
【73152】Re:複数条件の検索抽出 M_GUCHI 12/11/21(水) 11:57 回答[未読]
【73155】Re:複数条件の検索抽出 m_guchi 12/11/21(水) 19:40 お礼[未読]
【73145】複数条件の検索抽出
質問  M_GUCHI E-MAIL  - 12/11/20(火) 16:53 -
引用なし
パスワード
   かなり前にお世話になった者です。過去例を見たのですが適当なものが見つからずお願いする事にしました。よろしくお願いいたします。
「列がＡ〜Ｊまでの１０列、行は３００００行ある名簿で、C,D,E,F行の４条件に合致するＡ行（古い順の連番1〜30000）の連番を新しい順（連番の大きい順）に並べて最大５０件までを1行情報を付けて抽出表示させたい。」
【73146】Re:複数条件の検索抽出
発言  UO3  - 12/11/20(火) 17:34 -
引用なし
パスワード
   ▼M_GUCHI さん：

>C,D,E,F行 Ａ行

言葉は正しく使いましょうね。　列　ですね。

>1行情報を付けて

この意味が分かりにくいのですがシートの１行目がタイトル行で、それを付加したいということなんでしょうかね？

で、本件は典型的なフィルター処理の出番でしょうね。
オートフィルターで抽出したものを別シートにコピペ、
あるいはフィルターオプションで直接、別シートに抽出。
この別シートをＡ列で並べ替えたうえで、５０件で打ち止めということなら
５２行目以降をクリア。

こんなことでできますよね。
これをマクロ記録すれば、ベースのコードが生成されますよ。
【73147】Re:複数条件の検索抽出
発言  m_guchi  - 12/11/20(火) 21:46 -
引用なし
パスワード
   ▼UO3 さん：
申し訳ありません。Ａ行ではなくＡ列です。
１行情報とは、検索されたＡ列の連番の行情報（Ｂ〜Ｊ列）の事を言ったつもりでした。説明が下手で申し訳ありません。１行目にタイトルはつけますのでその点ももれていました。
>▼M_GUCHI さん：
>
>>C,D,E,F行 Ａ行
>
> 言葉は正しく使いましょうね。　列　ですね。
>
>>1行情報を付けて
>
>この意味が分かりにくいのですがシートの１行目がタイトル行で、それを付加したいということなんでしょうかね？
>
>で、本件は典型的なフィルター処理の出番でしょうね。
>オートフィルターで抽出したものを別シートにコピペ、
>あるいはフィルターオプションで直接、別シートに抽出。
>この別シートをＡ列で並べ替えたうえで、５０件で打ち止めということなら
>５２行目以降をクリア。
>
>こんなことでできますよね。
>これをマクロ記録すれば、ベースのコードが生成されますよ。
【73148】Re:複数条件の検索抽出
発言  UO3  - 12/11/21(水) 6:14 -
引用なし
パスワード
   ▼m_guchi さん：

おはようございます

・C,D,E,F列から抜き出す文字列の条件は、どこで指定する予定ですか？
　どこかのセルに４つの条件をいれておく？　InputBox等で指定させる？
　それとも、いつも固定？

・オートフィルターなり、フィルターオプションなり、実際にやってみましたか？
【73149】Re:複数条件の検索抽出
発言  UO3  - 12/11/21(水) 6:16 -
引用なし
パスワード
   ▼m_guchi さん：

追加です。
エクセルのバージョンは2003以前ですか？2007以降ですか？
【73150】Re:複数条件の検索抽出
回答  M_GUCHI E-MAIL  - 12/11/21(水) 10:22 -
引用なし
パスワード
   ▼UO3 さん
不備がありすいません。見よう見まねでマクロを少し作製したことがある程度で、基本が理解できていないものですからご迷惑を掛けています。面倒見て下さい。
整理します・・・・
まずバージョンは２００７以降です。
シートＡのセル<H1,I1,J1,K1>に検索条件があるとします。
シートＢに名簿があります。
シートＣの<A1>に検索抽出データを作る。
マクロ自動記録で或る程度やってはみましたが？・・・・宜しくお願いいたします。
>▼m_guchi さん：
>
>追加です。
>エクセルのバージョンは2003以前ですか？2007以降ですか？
【73151】Re:複数条件の検索抽出
発言  UO3  - 12/11/21(水) 11:19 -
引用なし
パスワード
   ▼M_GUCHI さん：

それではオートフィルター案とフィルターオプション案を。
フィルターオプション案では検索シートの M1:P2 を作業域として使っています。
もし、ここが別の項目で使われているなら、あいているところに変更してください。

Sub Sample1()　 'オートフィルター
　　Dim str1 As String
　　Dim str2 As String
　　Dim str3 As String
　　Dim str4 As String
　　Dim myR As Range
　　
　　Application.ScreenUpdating = False
　　
　　With Sheets("A")　　'検索条件シート
　　　　str1 = .Range("H1").Value
　　　　str2 = .Range("I1").Value
　　　　str3 = .Range("J1").Value
　　　　str4 = .Range("K1").Value
　　End With
　　
　　With Sheets("B")　　'名簿シート
　　　　.AutoFilterMode = False　　 '念のためリセット
　　　　.Range("A1").AutoFilter　　 'オートフィルター設定
　　　　Set myR = .AutoFilter.Range 'リストアドレス
　　End With
　　
　　myR.AutoFilter Field:=3, Criteria1:=str1
　　myR.AutoFilter Field:=4, Criteria1:=str2
　　myR.AutoFilter Field:=5, Criteria1:=str3
　　myR.AutoFilter Field:=6, Criteria1:=str4
　　
　　With Sheets("C")　　'転記シート
　　　　.UsedRange.ClearContents
　　　　If WorksheetFunction.Subtotal(106, myR.Columns(1)) > 1 Then '抽出あり
　　　　　　myR.Copy .Range("A1")
　　　　　　.Cells.Sort Order1:=xlDescending, Key1:=.Columns("A"), Header:=xlYes
　　　　　　With .Range("A1").CurrentRegion
　　　　　　　　If .Rows.Count > 51 Then
　　　　　　　　　　.Resize(.Rows.Count - 51).Offset(51).Clear
　　　　　　　　End If
　　　　　　End With
　　　　　　.Select
　　　　End If
　　End With
　　
　　myR.Parent.AutoFilterMode = False　 'オートフィルター解除
　　
　　Application.ScreenUpdating = True
　　MsgBox "抽出処理完了です"
　　
End Sub

Sub Sample2()　 'フィルターオプション
　　Dim cr As Range
　　
　　Application.ScreenUpdating = False
　　
　　With Sheets("A")　　'検索条件シート
　　　　Set cr = .Range("M1:P2")　　'作業用検索条件領域
　　　　cr.Rows(1).Value = Sheets("B").Range("C1:F1").Value '抽出項目ラベル
　　　　'検索条件のセット
　　　　cr(2, 1).Value = "'=" & .Range("H1").Value
　　　　cr(2, 2).Value = "'=" & .Range("I1").Value
　　　　cr(2, 3).Value = "'=" & .Range("J1").Value
　　　　cr(2, 4).Value = "'=" & .Range("K1").Value
　　End With
　　　　
　　With Sheets("C")　　'転記シート
　　　　.UsedRange.ClearContents
　　　　Sheets("B").Columns("A:J").AdvancedFilter Action:=xlFilterCopy, _
　　　　　　CriteriaRange:=cr, CopyToRange:=.Range("A1"), Unique:=False
　　　　.Cells.Sort Order1:=xlDescending, Key1:=.Columns("A"), Header:=xlYes
　　　　With .Range("A1").CurrentRegion
　　　　　　If .Rows.Count > 51 Then
　　　　　　　　.Resize(.Rows.Count - 51).Offset(51).Clear
　　　　　　End If
　　　　End With
　　　　cr.Clear
　　　　.Select
　　End With
　　
　　Application.ScreenUpdating = True
　　MsgBox "抽出処理完了です"
　　
End Sub
【73152】Re:複数条件の検索抽出
回答  M_GUCHI E-MAIL  - 12/11/21(水) 11:57 -
引用なし
パスワード
   ▼UO3 さん：
早速の回答本当にありがとうございます。
今見ただけで実行はしていませんが、まずは感謝をお伝いしたいと思います。
後ほどじっくり実施してみたいと思います。重ねてお礼申し上げます。

>▼M_GUCHI さん：
>
>それではオートフィルター案とフィルターオプション案を。
>フィルターオプション案では検索シートの M1:P2 を作業域として使っています。
>もし、ここが別の項目で使われているなら、あいているところに変更してください。
>
>Sub Sample1()　 'オートフィルター
>　　Dim str1 As String
>　　Dim str2 As String
>　　Dim str3 As String
>　　Dim str4 As String
>　　Dim myR As Range
>　　
>　　Application.ScreenUpdating = False
>　　
>　　With Sheets("A")　　'検索条件シート
>　　　　str1 = .Range("H1").Value
>　　　　str2 = .Range("I1").Value
>　　　　str3 = .Range("J1").Value
>　　　　str4 = .Range("K1").Value
>　　End With
>　　
>　　With Sheets("B")　　'名簿シート
>　　　　.AutoFilterMode = False　　 '念のためリセット
>　　　　.Range("A1").AutoFilter　　 'オートフィルター設定
>　　　　Set myR = .AutoFilter.Range 'リストアドレス
>　　End With
>　　
>　　myR.AutoFilter Field:=3, Criteria1:=str1
>　　myR.AutoFilter Field:=4, Criteria1:=str2
>　　myR.AutoFilter Field:=5, Criteria1:=str3
>　　myR.AutoFilter Field:=6, Criteria1:=str4
>　　
>　　With Sheets("C")　　'転記シート
>　　　　.UsedRange.ClearContents
>　　　　If WorksheetFunction.Subtotal(106, myR.Columns(1)) > 1 Then '抽出あり
>　　　　　　myR.Copy .Range("A1")
>　　　　　　.Cells.Sort Order1:=xlDescending, Key1:=.Columns("A"), Header:=xlYes
>　　　　　　With .Range("A1").CurrentRegion
>　　　　　　　　If .Rows.Count > 51 Then
>　　　　　　　　　　.Resize(.Rows.Count - 51).Offset(51).Clear
>　　　　　　　　End If
>　　　　　　End With
>　　　　　　.Select
>　　　　End If
>　　End With
>　　
>　　myR.Parent.AutoFilterMode = False　 'オートフィルター解除
>　　
>　　Application.ScreenUpdating = True
>　　MsgBox "抽出処理完了です"
>　　
>End Sub
>
>Sub Sample2()　 'フィルターオプション
>　　Dim cr As Range
>　　
>　　Application.ScreenUpdating = False
>　　
>　　With Sheets("A")　　'検索条件シート
>　　　　Set cr = .Range("M1:P2")　　'作業用検索条件領域
>　　　　cr.Rows(1).Value = Sheets("B").Range("C1:F1").Value '抽出項目ラベル
>　　　　'検索条件のセット
>　　　　cr(2, 1).Value = "'=" & .Range("H1").Value
>　　　　cr(2, 2).Value = "'=" & .Range("I1").Value
>　　　　cr(2, 3).Value = "'=" & .Range("J1").Value
>　　　　cr(2, 4).Value = "'=" & .Range("K1").Value
>　　End With
>　　　　
>　　With Sheets("C")　　'転記シート
>　　　　.UsedRange.ClearContents
>　　　　Sheets("B").Columns("A:J").AdvancedFilter Action:=xlFilterCopy, _
>　　　　　　CriteriaRange:=cr, CopyToRange:=.Range("A1"), Unique:=False
>　　　　.Cells.Sort Order1:=xlDescending, Key1:=.Columns("A"), Header:=xlYes
>　　　　With .Range("A1").CurrentRegion
>　　　　　　If .Rows.Count > 51 Then
>　　　　　　　　.Resize(.Rows.Count - 51).Offset(51).Clear
>　　　　　　End If
>　　　　End With
>　　　　cr.Clear
>　　　　.Select
>　　End With
>　　
>　　Application.ScreenUpdating = True
>　　MsgBox "抽出処理完了です"
>　　
>End Sub
【73155】Re:複数条件の検索抽出
お礼  m_guchi  - 12/11/21(水) 19:40 -
引用なし
パスワード
   ▼M_GUCHI さん：
>▼UO3 さん：
その後実行してみて、問題なく出来ました。本当に助かりました。心から御礼申し上げます・有難うございました。
>早速の回答本当にありがとうございます。
>今見ただけで実行はしていませんが、まずは感謝をお伝いしたいと思います。
>後ほどじっくり実施してみたいと思います。重ねてお礼申し上げます。
>
>>▼M_GUCHI さん：
>>
>>それではオートフィルター案とフィルターオプション案を。
>>フィルターオプション案では検索シートの M1:P2 を作業域として使っています。
>>もし、ここが別の項目で使われているなら、あいているところに変更してください。
>>
>>Sub Sample1()　 'オートフィルター
>>　　Dim str1 As String
>>　　Dim str2 As String
>>　　Dim str3 As String
>>　　Dim str4 As String
>>　　Dim myR As Range
>>　　
>>　　Application.ScreenUpdating = False
>>　　
>>　　With Sheets("A")　　'検索条件シート
>>　　　　str1 = .Range("H1").Value
>>　　　　str2 = .Range("I1").Value
>>　　　　str3 = .Range("J1").Value
>>　　　　str4 = .Range("K1").Value
>>　　End With
>>　　
>>　　With Sheets("B")　　'名簿シート
>>　　　　.AutoFilterMode = False　　 '念のためリセット
>>　　　　.Range("A1").AutoFilter　　 'オートフィルター設定
>>　　　　Set myR = .AutoFilter.Range 'リストアドレス
>>　　End With
>>　　
>>　　myR.AutoFilter Field:=3, Criteria1:=str1
>>　　myR.AutoFilter Field:=4, Criteria1:=str2
>>　　myR.AutoFilter Field:=5, Criteria1:=str3
>>　　myR.AutoFilter Field:=6, Criteria1:=str4
>>　　
>>　　With Sheets("C")　　'転記シート
>>　　　　.UsedRange.ClearContents
>>　　　　If WorksheetFunction.Subtotal(106, myR.Columns(1)) > 1 Then '抽出あり
>>　　　　　　myR.Copy .Range("A1")
>>　　　　　　.Cells.Sort Order1:=xlDescending, Key1:=.Columns("A"), Header:=xlYes
>>　　　　　　With .Range("A1").CurrentRegion
>>　　　　　　　　If .Rows.Count > 51 Then
>>　　　　　　　　　　.Resize(.Rows.Count - 51).Offset(51).Clear
>>　　　　　　　　End If
>>　　　　　　End With
>>　　　　　　.Select
>>　　　　End If
>>　　End With
>>　　
>>　　myR.Parent.AutoFilterMode = False　 'オートフィルター解除
>>　　
>>　　Application.ScreenUpdating = True
>>　　MsgBox "抽出処理完了です"
>>　　
>>End Sub
>>
>>Sub Sample2()　 'フィルターオプション
>>　　Dim cr As Range
>>　　
>>　　Application.ScreenUpdating = False
>>　　
>>　　With Sheets("A")　　'検索条件シート
>>　　　　Set cr = .Range("M1:P2")　　'作業用検索条件領域
>>　　　　cr.Rows(1).Value = Sheets("B").Range("C1:F1").Value '抽出項目ラベル
>>　　　　'検索条件のセット
>>　　　　cr(2, 1).Value = "'=" & .Range("H1").Value
>>　　　　cr(2, 2).Value = "'=" & .Range("I1").Value
>>　　　　cr(2, 3).Value = "'=" & .Range("J1").Value
>>　　　　cr(2, 4).Value = "'=" & .Range("K1").Value
>>　　End With
>>　　　　
>>　　With Sheets("C")　　'転記シート
>>　　　　.UsedRange.ClearContents
>>　　　　Sheets("B").Columns("A:J").AdvancedFilter Action:=xlFilterCopy, _
>>　　　　　　CriteriaRange:=cr, CopyToRange:=.Range("A1"), Unique:=False
>>　　　　.Cells.Sort Order1:=xlDescending, Key1:=.Columns("A"), Header:=xlYes
>>　　　　With .Range("A1").CurrentRegion
>>　　　　　　If .Rows.Count > 51 Then
>>　　　　　　　　.Resize(.Rows.Count - 51).Offset(51).Clear
>>　　　　　　End If
>>　　　　End With
>>　　　　cr.Clear
>>　　　　.Select
>>　　End With
>>　　
>>　　Application.ScreenUpdating = True
>>　　MsgBox "抽出処理完了です"
>>　　
>>End Sub
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1609 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free