Excel VBA質問箱 IV

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

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


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

【54270】フィルタオプション ウィル 08/3/2(日) 17:20 質問[未読]
【54272】Re:フィルタオプション かみちゃん 08/3/2(日) 17:29 発言[未読]
【54275】Re:フィルタオプション ウィル 08/3/2(日) 17:59 回答[未読]
【54277】Re:フィルタオプション Hirofumi 08/3/2(日) 19:10 回答[未読]
【54278】Re:フィルタオプション ウィル 08/3/2(日) 20:07 回答[未読]
【54279】Re:フィルタオプション Hirofumi 08/3/2(日) 20:48 回答[未読]
【54281】Re:フィルタオプション ウィル 08/3/2(日) 21:56 お礼[未読]

【54270】フィルタオプション
質問  ウィル  - 08/3/2(日) 17:20 -

引用なし
パスワード
   始めまして。
やりたいことは、複数の条件を指定して、別シートに抽出したいです。

自分なりにフィルタを使用して作成してみたのですが、
もう少し簡単にできないでしょうか?


Sub Macro11()
  Range("B9:H800").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
    "B1:F2"), CopyToRange:=Range("O1"), Unique:=False
  Columns("O:U").Select
  Selection.Cut
  Sheets("Sheet1").Select
  Cells.Select
  Application.CutCopyMode = False
  Selection.Delete Shift:=xlUp
  Range("A1").Select
  Sheets("リスト").Select
  Selection.Cut
  Sheets("Sheet1").Select
  ActiveSheet.Paste
  Sheets("リスト").Select
  
  Range("B2").Select
  Sheets("Sheet1").Select
  Range("A2").Select
End Sub


宜しくお願いします。

【54272】Re:フィルタオプション
発言  かみちゃん  - 08/3/2(日) 17:29 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>やりたいことは、複数の条件を指定して、別シートに抽出したいです。
>
>自分なりにフィルタを使用して作成してみた

まず確認ですが、このマクロ動きますか?

Application.CutCopyMode = False
が気になります。

動かないならば、シートの内容を説明していただけませんか?
検証のしようがないです。

【54275】Re:フィルタオプション
回答  ウィル  - 08/3/2(日) 17:59 -

引用なし
パスワード
   かみちゃんさん
ありがとうございます。
マクロボタンを押すとうごきます。
動かない可能性があるのでしょうか?

やりたいこととして、本来は、
リストのB10〜H800までに入っている情報を、
シート1のA2〜G2(名前・機関・科目を最低指定できれば大丈夫です)で指定して、A5に抽出したいのです。
その時前回の情報が、全てクリアにしてから抽出したいのですが、
できませんでした。

ですので、
リストのB10〜H800までに入っている情報を、
リストのB2〜F2で指定して、同一シートに抽出した後に
シート1に切取り、貼り付けました。
良い方法を教えて下さい。


リスト
氏名  日付  機関  科目  症状   指示    備考
加藤  2/3   A   あ   アア  特になし   ○
佐藤  2/3   A   あ   イイ  aaa      ○
加藤  2/4   A   あ   ウウ  aaa      △
加藤  3/2   B   い   エエ  aaa      △


シート1(加藤を指定した場合)はこのような感じにしたいです。
氏名  日付  機関  科目  症状   指示    備考
加藤  2/3   A   あ   アア  特になし   ○
加藤  2/4   A   あ   ウウ  aaa      △
加藤  3/2   B   い   エエ  aaa      △

宜しくお願いします。

【54277】Re:フィルタオプション
回答  Hirofumi  - 08/3/2(日) 19:10 -

引用なし
パスワード
   帰って難しく成ったかな?

リスト
   B   C   D   E   F    G     H
01  氏名  機関  科目
02  ="=加藤" *   *


09  氏名  日付  機関  科目  症状   指示    備考
10  加藤  2/3   A   あ   アア  特になし   ○
11  佐藤  2/3   A   あ   イイ  aaa      ○
12  加藤  2/4   A   あ   ウウ  aaa      △
13  加藤  3/2   B   い   エエ  aaa      △


Sheet1
   B   C   D   E   F    G     H
05  氏名  日付  機関  科目  症状   指示    備考
06  加藤  2/3   A   あ   アア  特になし   ○
07  加藤  2/4   A   あ   ウウ  aaa      △
08  加藤  3/2   B   い   エエ  aaa      △


Option Explicit

Public Sub Sample()

  '◆リストのデータ列数(B列〜F列)
  Const clngColumns As Long = 7
  
  Dim i As Long
  Dim lngRows As Long
  Dim rngList As Range '抽出元
  Dim rngExtract As Range '抽出範囲
  Dim rngCriteria As Range '条件範囲
  Dim strProm As String

  '◆Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngList = Worksheets("リスト").Cells(9, "B")

  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count _
          - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
  End With
  
  '◆抽出範囲を指定
  Set rngExtract = Worksheets("Sheet1") _
      .Cells(5, "B").Resize(, clngColumns)
  '◆条件範囲を指定(「氏名」、「機関」、「科目」の3列)
  Set rngCriteria = rngList.Parent.Cells(1, "B").Resize(2, 3)
  
  '画面更新を停止
'  Application.ScreenUpdating = False
  
  'AdvancedFilterを実行
  DoFilter rngList.Resize(lngRows + 1, clngColumns), _
      rngCriteria, rngExtract
  
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngExtract = Nothing
  Set rngCriteria = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Private Sub DoFilter(rngScope As Range, _
          rngCriteria As Range, _
          rngCopyTo As Range, _
          Optional blnUnique As Boolean)

'  AdvancedFilterを実行

  rngScope.AdvancedFilter _
      Action:=xlFilterCopy, _
      CriteriaRange:=rngCriteria, _
      CopyToRange:=rngCopyTo, _
      Unique:=blnUnique

End Sub

【54278】Re:フィルタオプション
回答  ウィル  - 08/3/2(日) 20:07 -

引用なし
パスワード
   Hirofumiさん
ありがとうございます。

条件範囲を指定(「氏名」、「機関」、「科目」の3列)を
変更する時と

抽出範囲を変更する時はどのようにしたらよろしいのでしょうか?

もしよろしければ教えて下さい。

宜しくお願いします。

【54279】Re:フィルタオプション
回答  Hirofumi  - 08/3/2(日) 20:48 -

引用なし
パスワード
   >条件範囲を指定(「氏名」、「機関」、「科目」の3列)を
>変更する時と
>
>抽出範囲を変更する時はどのようにしたらよろしいのでしょうか?


変更する部分は、

  '◆抽出範囲を指定
  Set rngExtract = Worksheets("Sheet1") _
      .Cells(5, "B").Resize(, clngColumns)
  '◆条件範囲を指定(「氏名」、「機関」、「科目」の3列)
  Set rngCriteria = rngList.Parent.Cells(1, "B").Resize(2, 3)
  

の2行です
詳しくは、Helpのフィルタオプション(AdvancedFilter)を見れば解ると思いますが?

「抽出範囲」は、抽出させるSheetの抽出させる列の列見出しの範囲を言います
詰まり、現状のコードでは、B5:H5の範囲と成っています
AdvancedFilterでは、必ず全ての列を元のListと同じ順番で抽出させる必要は無いので
例えば、Sheet2のD6:F6に、「氏名」、「日付」、「症状」を抽出したい場合

Sheet2を
   D   E   F
06  氏名  日付  症状

として、コードを

  '◆抽出範囲を指定
  Set rngExtract = Worksheets("Sheet2") _
      .Cells(6, "D").Resize(, 3)

とします
また、「条件範囲」も必要な列見出しとその下の条件だけを指定すれば良く
例として、Sheet2のE、F、G、H列の5行目に「氏名」、「機関」、「症状」、「科目」
を抽出条件として置くならば

Sheet2を
   E   F   G   H
05  氏名  機関  症状  科目
06  ="=加藤" *   *   *

と設定して

  '◆条件範囲を指定(「氏名」、「機関」、「症状」、「科目」の2行4列)
  Set rngCriteria = Worksheets("Sheet2").Cells(5, "E").Resize(2, 4)

とします
尚、解ると思いますが、.Resizeとは、その前の範囲を変更するRangeのプロパティです
詳しくはHelpを見て下さい

また、Upしたコードの「rngList.Parent」とは、
rngListの親(詰まり、レンジの親なのでSheet)を指します
今回の場合、rngListは、抽出元の先頭列見出しなので、
その親は、WorkSheets("リスト")と成ります

【54281】Re:フィルタオプション
お礼  ウィル  - 08/3/2(日) 21:56 -

引用なし
パスワード
   Hirofumiさん
どうもありがとうございました。

また分からないことがありましたら質問させていただきます。

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