VBAにて特定文字（セル）抽出

例
Sheet2
　　　　（E列）　　　　　（F列）
3
41　兵庫高速道路　　33333
42　阪神高速道路　　55555
52
63
64　阪神高速道路　　66666

Sheet2のE41からデータのある所（約200）までの決まった文字「阪神高速道路」とその隣（F列）のセットセルを抽出し、Sheet3のF3へ順にコピーしたいと思います。
*Sheet2のE41以降は空白ありません。

結果
Sheet3
　　　（F列）　　　　　（G列）
3　阪神高速道路　　55555
4　阪神高速道路　　66666
5
6
7　

　となるように。

Dim Cr As Range
With Sheets(2)
Set Cr = .Range("E1：F1")
Cr.Item(1).Formula = "=E41"
Cr.Item(2).Value = "'=阪神高速道路"
.Range("E41").CurrentRegion.AdvancedFilter _
xlFilterCopy, _
CriteriaRange:=Cr, _
CopyToRange:=Sheets(3).Range("F3")
End With

うまく抽出できません。お願い致します。

No.1 ベストアンサー 回答者： kazuhisa01 回答日時： 2009/07/27 12:08

質問するカテゴリが少し間違っている気がします。

プログラミングの方に質問すればもう少しいい回答が得られるかもしれません。

一応コードを乗せて置きます。
---------------------------------------------------------------------
Dim intIndex As Integer
Dim intWrite As Integer

'書き込み先の行カウントを指定
intWrite = 1

'Sheetの検索行指定(1が開始位置、10が終了位置)
For intIndex = 1 To 10
'セルの値が"阪神高速道路"の場合
If (Worksheets("Sheet2").Range("A" + CStr(intIndex)).Value = "阪神高速道路") Then
'ヒットした文字列と次のセルの値を指定したSheetの指定した書き込み先行から順に格納
Worksheets("Sheet3").Range("A" + CStr(intWrite)).Value = Worksheets("Sheet2").Range("A" + CStr(intIndex)).Value
Worksheets("Sheet3").Range("B" + CStr(intWrite)).Value = Worksheets("Sheet2").Range("B" + CStr(intIndex)).Value
'書き込み先の行カウントアップ
intWrite = intWrite + 1
End If
Next intIndex

この回答へのお礼

＞プログラミングの方に質問すればもう少しいい回答が得られるかもしれません。
次回からそうしてみます。
有難う御座いました。

お礼日時：2009/07/27 22:11

No.3 回答者： imogasi 回答日時： 2009/07/27 13:51

この程度の問題なら関数でも、出来ます。

その１方法はGoogleで「imogasi方式」で照会すれば、沢山の問題と、他の方の他の方式の解放も出てきます。
VBAですが、マクロの記録をとって、フィルタオプションに操作を記録をとると判る問題で、質問するほどのことではないので。
抜き出すシートが変わる場合は、注意が必要でこの質問の場合はSheet3の側で操作しなければならない。
ーー
ほかに検索の操作でマクロの記録をとる方法もある。FilterでなくFindメソッドになる。
ーー
１行ずつ全行総なめにして、阪神高速道路　かどうか判別しても、それほど時間の問題にはなるまい。
ーー
本質問のSet Cr = .Range("E1：F1")
は明らかにおかしい。見出しと条件になる内容とを指し示すので最低でもF2になる。
エクセルの（どちらかと言うと操作や知識）経験が少ないことが露呈したようだ。
ーー
Cr.Item(1).Formula = "=E41"
のItemなんて普通はあまり使わない表現だと思う。もちろんItemも使うのはよいが、VBAの解説書にほとんど使われていないだろう。

この回答へのお礼

回答有難う御座います。
他のマクロ実行との組合せにより本問題も と考えており、ワークシート関数は頭にありませんでした。

参考にさせて頂きます。

お礼日時：2009/07/27 21:59

No.2 回答者： Wendy02 回答日時： 2009/07/27 13:18

こんにちは。

フィルタオプションを使うためには、Sheet2 のE41 に、このようなタイトル名を入れます。
　道路名　番号
　データ　・・・
　データ　・・・

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

Sub Test1()
　　Dim Cr As Range
　　Worksheets("Sheet3").Range("F3").CurrentRegion.ClearContents
　　With Worksheets("Sheet2")
　　　　Set Cr = .Range("E1：E2")
　　　　Cr.Cells(1, 1).Formula = "=E41"　'Itemでも可
　　　　Cr.Cells(2, 1).Value = "阪神高速道路"
'フィルタオプション
　　　　.Range("E41").CurrentRegion.AdvancedFilter _
　　　　xlFilterCopy, _
　　　　CriteriaRange:=Cr, _
　　　　CopyToRange:=Worksheets("Sheet3").Range("F3")
　　End With
　　Set Cr = Nothing
End Sub
'-------------------------------------------

なお、VBが分かるといって、VBAが分かるとは必ずしも言えないのが、VBAの難しいところです。VBAには、VBAの世界があります。
それと、文字比較だけを目的にするなら、Like 演算子やStrComp 関数でするほうが良いです。

この回答へのお礼

私のVBAはWeb参考を元に作ってみました。
参考の選択が間違えていた気がします。

Like 演算子やStrComp 関数　参考にしてみます。

お礼日時：2009/07/27 22:07