Excel VBA質問箱 IV

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

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


1611 / 13646 ツリー ←次へ | 前へ→

【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 -

引用なし
パスワード
   かなり前にお世話になった者です。過去例を見たのですが適当なものが見つからずお願いする事にしました。よろしくお願いいたします。
「列がA〜Jまでの10列、行は30000行ある名簿で、C,D,E,F行の4条件に合致するA行(古い順の連番1〜30000)の連番を新しい順(連番の大きい順)に並べて最大50件までを1行情報を付けて抽出表示させたい。」

【73146】Re:複数条件の検索抽出
発言  UO3  - 12/11/20(火) 17:34 -

引用なし
パスワード
   ▼M_GUCHI さん:

>C,D,E,F行 A行

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

>1行情報を付けて

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

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

こんなことでできますよね。
これをマクロ記録すれば、ベースのコードが生成されますよ。

【73147】Re:複数条件の検索抽出
発言  m_guchi  - 12/11/20(火) 21:46 -

引用なし
パスワード
   ▼UO3 さん:
申し訳ありません。A行ではなくA列です。
1行情報とは、検索されたA列の連番の行情報(B〜J列)の事を言ったつもりでした。説明が下手で申し訳ありません。1行目にタイトルはつけますのでその点ももれていました。
>▼M_GUCHI さん:
>
>>C,D,E,F行 A行
>
> 言葉は正しく使いましょうね。 列 ですね。
>
>>1行情報を付けて
>
>この意味が分かりにくいのですがシートの1行目がタイトル行で、それを付加したいということなんでしょうかね?
>
>で、本件は典型的なフィルター処理の出番でしょうね。
>オートフィルターで抽出したものを別シートにコピペ、
>あるいはフィルターオプションで直接、別シートに抽出。
>この別シートをA列で並べ替えたうえで、50件で打ち止めということなら
>52行目以降をクリア。
>
>こんなことでできますよね。
>これをマクロ記録すれば、ベースのコードが生成されますよ。

【73148】Re:複数条件の検索抽出
発言  UO3  - 12/11/21(水) 6:14 -

引用なし
パスワード
   ▼m_guchi さん:

おはようございます

・C,D,E,F列から抜き出す文字列の条件は、どこで指定する予定ですか?
 どこかのセルに4つの条件をいれておく? 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 さん
不備がありすいません。見よう見まねでマクロを少し作製したことがある程度で、基本が理解できていないものですからご迷惑を掛けています。面倒見て下さい。
整理します・・・・
まずバージョンは2007以降です。
シートAのセル<H1,I1,J1,K1>に検索条件があるとします。
シートBに名簿があります。
シートCの<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

1611 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free