Excel VBA質問箱 IV

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

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


27772 / 76732 ←次へ | 前へ→

【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

1 hits

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

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