エクセル練習問題:フィルター(VBA)


スポンサードリンク

問題    topへ

解答例    topへ

問題1の解答例    topへ


B C D E F G H
25 伝票 日付 担当者 型番 単価 数量 売上金額
26 1001 2006/1/1 岡田 A-001B 5,000 15 75,000
27 1002 2006/1/1 上村 A-001W 5,000 22 110,000
28 1006 2006/2/1 岡田 A-001W 5,000 12 60,000
29 1007 2006/3/1 上村 B-022B 6,000 13 78,000
30 1008 2006/3/1 岡田 C-105B 8,000 12 96,000
31 1010 2006/4/1 上村 B-033W 7,000 14 98,000
32 1012 2006/4/1 岡田 B-033W 7,000 22 154,000
33 1014 2006/5/1 上村 C-105W 8,000 23 184,000
34 1016 2006/6/1 岡田 C-105B 8,000 18 144,000
  1. コードの例
    Sub filter01()
      Dim myRange As Range
      Application.ScreenUpdating = False
      Set myRange = Worksheets("Sheet1").Range("B2:H19")
      'フィルターがかかっていたらオフにします
      With Worksheets("Sheet1")
        If .AutoFilterMode Then
          .AutoFilterMode = False
        End If
        'オートフィルターをかけます
        myRange.AutoFilter _
               Field:=3, _
               Criteria1:="岡田", Operator:=xlOr, _
               Criteria2:="上村"

        '抽出データをコピー&貼り付けします
        myRange.SpecialCells(xlCellTypeVisible).Copy Worksheets("Sheet1").Range("B25")
        .AutoFilterMode = False
      End With
    '
      Application.ScreenUpdating = True
      Set myRange = Nothing
    End Sub

問題2の解答例    topへ


B C D E F G H
25 伝票 日付 担当者 型番 単価 数量 売上金額
26 1002 2006/1/1 上村 A-001W 5,000 22 110,000
27 1003 2006/1/1 相沢 C-105W 8,000 14 112,000
28 1006 2006/2/1 岡田 A-001W 5,000 12 60,000
29 1009 2006/3/1 相沢 A-001W 5,000 16 80,000
30 1010 2006/4/1 上村 B-033W 7,000 14 98,000
31 1012 2006/4/1 岡田 B-033W 7,000 22 154,000
32 1014 2006/5/1 上村 C-105W 8,000 23 184,000
33 1015 2006/5/1 井上 B-033W 7,000 14 98,000
  1. コードの例
    Sub filter02()
      Dim myRange As Range
      Application.ScreenUpdating = False
      Set myRange = Worksheets("Sheet1").Range("B2:H19")
      'フィルターがかかっていたらオフにします
      With Worksheets("Sheet1")
        If .AutoFilterMode Then
          .AutoFilterMode = False
        End If
        'オートフィルターをかけます
        myRange.AutoFilter _
              Field:=4, _
              Criteria1:="*W*"

        '抽出データをコピー&貼り付けします
        myRange.SpecialCells(xlCellTypeVisible).Copy Worksheets("Sheet1").Range("B25")
        .AutoFilterMode = False
      End With
    '
      Application.ScreenUpdating = True
      Set myRange = Nothing
    End Sub

問題3の解答例    topへ


B C D E F G H
25 伝票 日付 担当者 型番 単価 数量 売上金額
26 1001 2006/1/1 岡田 A-001B 5,000 15 75,000
27 1006 2006/2/1 岡田 A-001W 5,000 12 60,000
28 1008 2006/3/1 岡田 C-105B 8,000 12 96,000
  1. コードの例:Excel2007以降の場合
    Sub filter03()
      Dim myRange As Range
      Application.ScreenUpdating = False
      Set myRange = Worksheets("Sheet1").Range("B2:H19")
      'フィルターがかかっていたらオフにします
      With Worksheets("Sheet1")
        If .AutoFilterMode Then
          .AutoFilterMode = False
        End If
        'オートフィルターをかけます
        myRange.AutoFilter _
               Field:=3, _
               Criteria1:="岡田"
        myRange.AutoFilter _
               Field:=7, _
               Criteria1:=xlFilterBelowAverage, Operator:=xlFilterDynamic

        '抽出データをコピー&貼り付けします
        myRange.SpecialCells(xlCellTypeVisible).Copy Worksheets("Sheet1").Range("B25")
        .AutoFilterMode = False
      End With
    '
      Application.ScreenUpdating = True
      Set myRange = Nothing
    End Sub
  2. コードの例
    • Excel2003以前ではxlFilterBelowAverageが使えないので、ワークシート関数で平均を求めそれを条件に書いています。
    Sub filter04()
      Dim myRange As Range
      Dim myAve As Double
      Application.ScreenUpdating = False
      Set myRange = Worksheets("Sheet1").Range("B2:H19")
      'フィルターがかかっていたらオフにします
      With Worksheets("Sheet1")
        If .AutoFilterMode Then
          .AutoFilterMode = False
        End If
        'オートフィルターをかけます
        myRange.AutoFilter _
               Field:=3, _
               Criteria1:="岡田"
        myAve = Application.WorksheetFunction.Average(Worksheets("Sheet1").Range("H3:H19"))
        myRange.AutoFilter _
               Field:=7, _
               Criteria1:="<" & myAve
        '抽出データをコピー&貼り付けします
        myRange.SpecialCells(xlCellTypeVisible).Copy Worksheets("Sheet1").Range("B25")
        .AutoFilterMode = False
      End With
    '
      Application.ScreenUpdating = True
      Set myRange = Nothing
    End Sub

スポンサードリンク



よねさんのExcelとWordの使い方エクセル練習問題:目次|フィルター(VBA)