VBAで条件が一致する行のデータを別シートに抽出

質問

"Sheet1"のA列に区分（文字列）、B列～D列に分析数値があり
A列の文字が条件に一致した行のデータを"Sheet2"にコピー、
元の"Sheet1"のデータは行ごと削除といった形で考えているのですが、どうも上手くいきません。

Dim Keywrd As String
？？？
With Worksheets("Sheet1").Columns("A:A")
Set Keywrd = .Find("キーワード", LookIn:=xlValues)
？？？
End With
Set Keywrd = Nothing
TargetCell.EntireRow.Select
Selection.Delete Shift:=xlUp
End Sub

？？？部分の変数宣言と処理内容をどうすれば良いか、ご教授願えますでしょうか。

回答No.3

Wendy02 · ベストアンサー

こんばんは。

#1の回答者です。一度きりなら、こんな風に直してみたらよいと思います。質問のコードは、変数の流れがおかしくなっているようです。

Sub Macro1()
　　Dim Keywrd As String
　　Dim TargetCell As Range
　　Keywrd = InputBox("キーワードを入れてください", "キーワード入力")
　　If Keywrd = "" Then Exit Sub
　　With Worksheets("Sheet1").Columns("A:A")
　　　　Set TargetCell = .Find(Keywrd, LookAt:=xlWhole, LookIn:=xlValues)
　　　　If TargetCell Is Nothing Then
　　　　　　MsgBox Keywrd & " は見つかりません。"
　　　　　　Exit Sub
　　　　End If
　　End With
　　'Keywrd = "" ''不要
　　TargetCell.EntireRow.Copy Worksheets("Sheet2").Range("A1")
　　TargetCell.Delete Shift:=xlUp

End Sub

--------------------------------------
#1 のコードを考え直し修正しました。
私のコードは、必ず、検索値に対して複数、該当するものがあるという条件になっています。

---------------------------------------------
Sub TestFind2()
　Dim myKeyWord As String
　Dim FirstAdd As String
　Dim c As Range
　Dim ur As Range
　myKeyWord = Application.InputBox("検索文字を入れてください", "検索+移動", Type:=2)
　If myKeyWord = "" Or myKeyWord = "False" Then Exit Sub

　With Worksheets("Sheet1").Columns(1)
　.Cells(1).Select
　Set c = .Find( _
　　　　　　What:=myKeyWord, _
　　　　　　LookIn:=xlValues, _
　　　　　　LookAt:=xlWhole, _
　　　　　　MatchCase:=False, _
　　　　　　MatchByte:=True)

　　If Not c Is Nothing Then
　　　　　Set ur = c.EntireRow
　　　　　FirstAdd = c.Address
　　　　Do
　　　　　 Set ur = Union(c.EntireRow, ur)
　　　　　 Set c = .FindNext(c)
　　　　Loop Until (c Is Nothing) Or (FirstAdd = c.Address)
　　 End If
　　 ur.Copy Worksheets("Sheet2").Range("A1")
　　 ur.Delete Shift:=xlShiftUp
End With
　　 Set ur = Nothing
End Sub

お礼

思い通りに動作しましたっ！すごいです。。。
この動作は一度だけになりますので、上の記述を参考にさせて頂きました。

Wendy02さんには前回にも回答頂き、ありがとうございます。
このところ作業を中断しておりましたが、前回の続きです。

全体イメージは見えてきましたので、あとは詳細の詰めとなっております。

回答No.2

imogasi

むつかしい記述になり過ぎていると思う。
FindメソッドはFindNextメソッドなどアリ、初心者にはむつかしい。
別途単純な方法（総当り法）でやってみる。
小生にとって馬鹿の１つ覚えのような方法だが
Sheet1のA列のaの行をSheet2へ抜き出すには
(下記では　i は処理対象行ポインタ、K　は書き出し行ポインタ）
Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
k = 2
i = 2
Do While Cells(i, "A") <> ""
If sh1.Cells(i, "A") = "a" Then
sh2.Cells(k, "A") = sh1.Cells(i, "A")
sh2.Cells(k, "B") = sh1.Cells(i, "B")
sh1.Rows(i).Delete
k = k + 1
Else
i = i + 1
End If
Loop
End Sub
例データ
Sheet1　スタート状態
　A1:B９
区分 計数
a 3
b 5
a 2
b 3
c 1
c 2
a 6
a 7
Sheet2　A2:B5
a 3
a 2
a 6
a 7
Sheet1 結果
区分 計数
b 5
b 3
c 1
c 2

お礼

ご教授ありがとうございます。
こんな方法もあったんですね。
VBAを記述する上で、自ら難しくしてしまっている感じです。

ゴール地点は同なのに到達する道筋が色々あって…奥深いですね。
参考に致します。

回答No.1

Wendy02

こんばんは。

今回の内容の　Find メソッドからでは、かなりむつかしいです。それと、Find メソッドの引数を省略するのが良く分からないです。確か、ワークシート側の検索置換にひきずられてしまったような気がします。

------------------------------------------

Sub TestFind()
　Dim myKeyWord As String
　Dim c As Range
　Dim r As Range
　Dim i As Long
　myKeyWord = Application.InputBox("検索文字を入れてください", "検索+移動", Type:=2)
　If myKeyWord = "" Or myKeyWord = "False" Then Exit Sub

　With Worksheets("Sheet1").Columns(1)
　.Cells(1).Select
　Set c = .Find( _
　　　　　　What:=myKeyWord, _
　　　　　　LookIn:=xlValues, _
　　　　　　LookAt:=xlWhole, _
　　　　　　MatchCase:=False, _
　　　　　　MatchByte:=True)

　　If Not c Is Nothing Then
　　　　Do
　　　　　 If Not r Is Nothing Then
　　　　　　 r.Delete
　　　　　　Set r = Nothing
　　　　　　End If
　　　　　　On Error Resume Next
　　　　　　'削除すると、オブジェクトを失い、エラーが発生する
　　　　　　c.EntireRow.Copy Worksheets("Sheet2").Range("A1").Offset(i)
　　　　　　If Err.Number > 0 Then Exit Do
　　　　　　On Error GoTo 0
　　　　　　Set r = c.EntireRow
　　　　　　Set c = .FindNext(c)
　　　　　　i = i + 1
　　　　Loop
　　 End If
End With
End Sub