ExcelのVBAでの抽出

質問

初心者です。よろしくお願いいたします。

sheet1の"A2"～"C6"に簡単な表を作りました。
A列に人の名前が入力されています。
そこで、A列の名前が"花子"のデータだけを抽出
してSheet2へコピーしたいのです。
そこで試行錯誤の上、下のような記述をしました。

Sub 抽出()

Application.ScreenUpdating = False

Sheets("sheet2").Activate
Sheets("sheet2").Columns("A:C").Clear

With Sheets("Sheet1")

.Range("A2").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:="花子", CopyToRange:=Sheets("sheet1").Range("A2"), Unique:=False

End With

Application.ScreenUpdating = True

End Sub

しかし、うまくいきません（TT）
エラー:400　とかでるんですけど
なにがいけなんでしょうか・・。
他にもAdvancedFilterを使うさいに気をつけること
がありましたらご指導ください。
(項目行の中のセルが統合されていたりすると
うまくいかない・・・とかあるんでしょうか。)
よろしくご指導ください。お願いいたします。

回答No.2

nishi6 · ベストアンサー

下のような表を想定しました。
フィルターを使うためにF1:F2に検索する項目名と検索する名前をセットします。

　　　Ａ　　　Ｂ　　　　Ｃ　　　Ｄ　　　Ｅ　　　Ｆ
１　名前　　項目１　　項目２　　　　　　　　　名前
２　太郎　　１００　　１５０　　　　　　　　　花子
３　花子　　２００　　２５０
４　次郎　　３００　　３５０
５　花子　　４００　　４５０
６　三郎　　５００　　５５０

マクロを少し修正します。これで動くでしょう。

Sub 抽出()

　　Application.ScreenUpdating = False

　　Sheets("sheet2").Activate
　　Sheets("sheet2").Columns("A:C").Clear

　　With Sheets("Sheet1")
　　　　'//+++++++++++++++++++++++++++++++++++++++++++++++++++++++
　　　　'CriteriaRange:=.Range("F1:F2")　に修正
　　　　'CopyToRange:=Sheets("sheet2").Range("A1")　に修正
　　　　'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
　　　　.Range("A2").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
　　　　CriteriaRange:=.Range("F1:F2"), _
　　　　CopyToRange:=Sheets("sheet2").Range("A1"), Unique:=False
　　End With

　　Application.ScreenUpdating = True

End Sub

＞他にもAdvancedFilterを使うさいに気をつけることがありましたらご指導ください。
オブジェクトブラウザのHELPなどをよく読むことが大事でしょう。

＞(項目行の中のセルが統合されていたりするとうまくいかない・・・とかあるんでしょうか。)
AdvancedFilter はデータベース的な使い方をするメソッドと思っているので、結合セルがあるデータで使ったことはありません。
動いたとしても、データの欠落がなく抽出ができたかは保証されないと思います。多分、２セルを結合した状態で行えば、片方はデータ無しとかになるでしょう。

結合については、列単位で結合したか、個別のセル単位で結合したかで結果が異なってくるでしょう。

ご参考に。

お礼

なるほど、詳しく説明いただきありがとうございました！助かりました。

回答No.3

ja7awu

> 項目行の中のセルが統合されていたりするとうまくいかない・・・

解決しましたでしょうか。

結合状態のままで別シートに行抽出するのであって、マクロで処理する場合は、
フィルタを使わない方が、いいのではないかと思います。

下記のマクロを実行すると結合状態は、そのままで書式ごと行抽出します。
宜しかったらテストしてみてください。

必要により、コードの「指定事項」を変更してください。

Sub 行結合対応データ抽出()
'------- 指定事項 ----------------
Const 抽出元シート名 = "Sheet1"
Const 抽出先シート名 = "Sheet2"
Const 見出し行数 = 1 ' データより上部の行数指定
Const 検索列 = "A"
Const 検索データ = "花子"
'---------------------------------
Dim Rng As Range
Dim Rw As Long
Dim N As Long
Application.ScreenUpdating = False
Sheets(抽出先シート名).UsedRange.EntireRow.Delete
Sheets(抽出元シート名).Select
Set Rng = Range(検索列 & "1", Range(検索列 & "65536").End(xlUp))
Rw = 1
Range(検索列 & "1").Select
Do Until Intersect(Selection, Rng) Is Nothing
　　If ActiveCell.Row <= 見出し行数 Or ActiveCell.Value = 検索データ Then
　　　　Selection.EntireRow.Copy _
　　　　Destination:=Sheets(抽出先シート名).Rows(Rw)
　　　　Rw = Rw + Selection.Count
　　End If
　　ActiveCell.Offset(1).Select
Loop
Application.ScreenUpdating = True
Set Rng = Nothing
End Sub

お礼

ありがとうございます！
とりあえずコピーさせていただいて
分析して理解していきます！ありがとう
ございました！

回答No.1

imogasi

＞CriteriaRange:="花子",
ここがおかしいのではないでしょうか。
Ｒａｎｇｅは「セル範囲」を指定する、であるはず。範囲に名前をつけたならともかく。
（テストデータ）
Ａ１：Ａ６
氏名
太郎
花子
次郎
素直
五郎
（条件）
Ｄ１：Ｄ２
氏名
花子
（ＶＢＡ）
Sub Macro2()
Range("A1:A6").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"D1:D2"), CopyToRange:=Range("A9:A15"), Unique:=False
End Sub
でうまく行きましたが。
（結果）
Ａ９：Ａ１０
氏名
花子
（セル結合）
Ａ３：Ａ４をセル結合して、値を花子として実行しましたがうまく行くようです。

お礼

ありがとうございます。
なぜか統合されている箇所がありそこを
はずしたらうまくいきました！
もう少し調べてみます、ありがとうございました！