マクロ：フィルタの選択について

質問

例
A列に野菜の種別（大根やトマトなど）が入力されており
B列に県名が入力されています。c列以降もあり。

フィルタでA列の野菜名を選択し、抽出された結果を別シートに
貼るという野菜別のシートを作る単純な作業の繰り返しを
マクロで設定したいのですが
マクロの記録で行うと、フィルタで野菜名を選択する時に
Selection.AutoFilter Field:=4, Criteria1:="大根"
というように、名前が入力されています。

フィルタの選択を上から下に4つ目、5つ目という感じで
下に選択していくマクロを教えて頂ければと思います。

また他に良い方法がありましたら、アドバイス宜しくお願い致します。

回答No.5

Wendy02 · ベストアンサー

こんばんは。

細かい点を修正しました。シート名は最初に考えていたのですが、忘れていましたので加えます。
それと、副産物としてできた、シートの並べ替えプログラムと、シートの初期化のプログラムもつけて置きましたので、何かの時に役に立つと思います。バグはないつもりですが、一度、コードをざっと見てから試してみてください。

データシートを、シート1 なら、そのままで良いのですが、右からシート1,2 と置いて置いておきたい場合は、以下を、= 2　と入れてあげます。

Const INI As Integer = 1 'そのままにして置くシート数

'標準モジュール
'-------------------------------------------
Const INI As Integer = 1 'そのままにして置くシート数 (INI >1)
Sub FilterTest2()
'オートフィルタから、個別データのシートの移し替えのプログラム
　　Dim r As Range
　　Dim Ar() As Variant
　　Dim i As Long
　　Dim j As Long
　　Dim c As Variant
　　j = Worksheets.Count 'シートの元の数
　　If INI < 1 Then Exit Sub '0の場合は、マクロは進まない。
　　With Worksheets("Sheet1")
　　If .FilterMode Then .ShowAllData
　　　　With .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
　　　　　　.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
　　　　　　Set r = .SpecialCells(xlCellTypeVisible)
　　　　End With
　　　　ReDim Ar(r.Count - 1)
　　　　For Each c In r.Cells 'タイトルは抜く
　　　　　　Ar(i) = c.Value
　　　　　　i = i + 1
　　　　Next c
　　　　.ShowAllData
　　　　If (UBound(Ar) + INI) > j Then 'Sheet抜く　
　　　　　　For i = 1 To (UBound(Ar) - j + INI) 'Sheet を抜く
　　　　　　　　Worksheets.Add After:=Worksheets(Worksheets.Count)
　　　　　　Next i
　　　　End If
　　　　i = 1
　　　　.Select
　　　　For i = 1 To UBound(Ar)
　　　　　　.Cells(1, 1).CurrentRegion.AutoFilter _
　　　　　　Field:=1, _
　　　　　　Criteria1:=Ar(i)
　　　　　　With .AutoFilter.Range
　　　　　　　　.SpecialCells(xlCellTypeVisible).Copy Worksheets(i + INI).Range("A1")　'Sheet を抜く
　　　　　　　　Worksheets(i + INI).Name = Ar(i)　'シート名をつける
　　　　　　End With
　　　　Next
　　　　.Range("A1").AutoFilter
　　End With
End Sub
'-------------------------------------------
Sub Sample_SortWorksheet()
'シートの並べ替え(ただし、JISコード並び）
　　Dim sName As String
　　Dim iCount As Integer
　　Dim i As Integer
　　Dim j As Integer

　　Application.ScreenUpdating = False
　　iCount = Worksheets.Count
　　For i = INI + 1 To iCount - 1
　　　　'シート名の最小値を取得します
　　　　sName = Worksheets(i).Name
　　　　For j = i + 1 To iCount
　　　　　　If Worksheets(j).Name < sName Then
　　　　　　　　sName = Worksheets(j).Name
　　　　　　End If
　　　　Next
　　　　'シート名が最小のシートを現在の先頭に移動する
　　　　Worksheets(sName).Move Before:=Worksheets(i)
　　Next
　　Worksheets(1).Select
　　Application.ScreenUpdating = True
End Sub
'-------------------------------------------
Sub SheetClear()
'シートの消去とシート名の初期化
Dim i As Long
　For i = INI + 1 To Worksheets.Count 'シート2～
　 Worksheets(i).UsedRange.Clear
　 Worksheets(i).Name = "Sheet" & CStr(i)
　Next i
End Sub

お礼

難しすぎてなんとなくしか仕組みを理解できませんでしたが
すごいですね！シート名が出来ました。

使わせて頂きます。
ありがとうございました！感謝です。

回答No.4

mt2008

No.2です。

> このマクロは今使用しているマクロのフィルタ選択の箇所に
> 組み込むのでしょうか？

そうです。
「　'取得した要素を表示」以前の部分で、配列sTempを作り、ループを回して、フィルターをかけて別シートに貼っていってください。

「　'取得した要素を表示」以降の部分は、配列sTempに全ての要素が入ったいることを見えるようにしただけですので、本来は不要です。

お礼

ご回答ありがとうございます。
上記の通り実際にやってみます。ありがとうございました！

回答No.3

Wendy02

こんにちは。

注意：Sheet1に元のデータがあるとして、Sheet2 目以降はすべて空の状態にしてください。もしデータがあったら上書きされてしまいます。必要な分だけ、シートが自動的に増えますから、シート数がたらなくても大丈夫です。

ただし、質問の疑問点としては、
>　Selection.AutoFilter Field:=4, Criteria1:="大根"

このField:=4 というのが、質問内容と矛盾しているように思います。
A列が野菜名と書いているのに、Field:=4では、列が違います。
あくまでも、以下のコードは、A1 から、表が行列（Matrix)で出来上がっているものとして作られています。

'-------------------------------------------

'Option Explicit

Sub FilterTest1()
　　Dim r As Range
　　Dim Ar() As Variant
　　Dim i As Long
　　Dim j As Long
　　Dim c As Variant
　　With Worksheets("Sheet1")
　　If .FilterMode Then .ShowAllData
　　　　With .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
　　　　　　.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
　　　　　　Set r = .SpecialCells(xlCellTypeVisible)
　　　　End With
　　　　ReDim Ar(r.Count - 1)
　　　　For Each c In r.Cells　'タイトルは使用しない
　　　　　　Ar(i) = c.Value
　　　　　　i = i + 1
　　　　Next c
　　　　.ShowAllData
　　　　If (r.Count - 1) > Worksheets.Count Then
　　　　　　j = (r.Count - 1) - Worksheets.Count
　　　　　　For i = 1 To j
　　　　　　　　Worksheets.Add After:=Worksheets(Worksheets.Count)
　　　　　　Next i
　　　　End If
　　　　i = 1
　　　　.Select
　　　　For i = 1 To r.Count - 1
　　　　　　.Cells(1, 1).CurrentRegion.AutoFilter _
　　　　　　Field:=1, _
　　　　　　Criteria1:=Ar(i)
　　　　　　With .AutoFilter.Range
　　　　　　　　.SpecialCells(xlCellTypeVisible).Copy Worksheets(i + 1).Range("A1")
　　　　　　End With
　　　　Next
　　　　.Range("A1").AutoFilter
　　End With
End Sub

補足

このまま使用して即作成できました。
ありがとうございます。
Field:=4は間違いです。実際には4列目に野菜名が
あって作っていたのですが、後から1列目に移動しました。

シートが自動的に増えますが
それぞれにシート名をつけるとしたら
この場合どこに入れたらいいのでしょうか？

ActiveSheet.Name = Range("A2")
を使用していました。

ご教示宜しくお願い致します。

回答No.2

mt2008

フィルタを掛けて、その結果を別シートに貼る所は出来るのですよね？
後は、A列の全要素が取り出せれば良いと理解しました。

こんな感じでA2以下のセルの全要素を取得して、要素毎にフィルタを掛けては如何でしょう。

Sub Sample()
　Dim nRowA, nCount, i
　Dim sData, sTemp
　nRowA = Cells(Rows.Count, 1).End(xlUp).Row
　ReDim sTemp(0)
　nCount = 0
　For i = 2 To nRowA
　　sData = Cells(i, 1).Value
　　If Application.WorksheetFunction.CountIf(Range(Cells(i + 1, 1), Cells(nRowA + 1, 1)), sData) = 0 Then
　　　ReDim Preserve sTemp(nCount)
　　　sTemp(nCount) = sData
　　　nCount = nCount + 1
　　End If
　Next i

　'取得した要素を表示
　For i = 0 To (nCount - 1)
　　sStr = sStr & sTemp(i) & ","
　Next i
　MsgBox ("要素数：" & nCount & " 要素：" & sStr)
End Sub

補足

要素が表示され、OKをクリックしましたが何も動作がなく？？
このマクロは今使用しているマクロのフィルタ選択の箇所に
組み込むのでしょうか？
すみません、宜しくお願い致します。

回答No.1

KURUMITO

元のデータがシート1に入力されているとします。
Ａ2セルから下方に野菜名があるとして、フィルタを行った結果をシート2に貼り付けるとして、フィルタで野菜名を選択するときですが次のようにしてはどうでしょう。
例えばシート2のＡ1セルにシート1のＡ列で最初に出てくる野菜名が1で、次のでてくる野菜名が２のようにその数値を入力することでシート1でのフィルタが行われるようにします。そのためにシート1には予め作業列を用意します。
例えばシート1のＤ2セルに次の式を入力し下方にオートフィルドラッグします。
=IF(COUNTIF(A$2:A2,A2)=1,MAX(D$1:D1)+1,"")
これで最初にＡ列に出てくる野菜名に１が、次に出てくる野菜名に２が・・・と番号が振られます。
そこでマクロの作成ですがシート2について次のようなマクロにしてはどうでしょう。
Private Sub Worksheet_Change(ByVal Target As Range)
Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")
If Target = WS2.Range("A1") And WS2.Range("A1") <> "" Then
If Target.Value <= WorksheetFunction.Max(WS1.Range("D:D")) Then
WS1.Activate
WS1.Range("A1").Select
RowPos = WorksheetFunction.Match(WS2.Range("A1").Value, WS1.Range("D:D"), 0)
Namae = WS1.Range("A" & RowPos).Value
Selection.AutoFilter Field:=1, Criteria1:=Namae
End If
End If
End Sub
Ａ1セルに1から順に数値を大きくしていくことですべての野菜についてオートフィルタを行うことができますね。

お礼

式を入れるだけで1,2,3・・・の方が野菜名よりも選択しやすいですね。
シート2にマクロを入れて実際にやってみたのですが、無反応・・・。
今使っているマクロとの組み合わせがだめなのでしょうか。
難しい、ちょっと勉強してみます。
ありがとうございました。