エクセルマクロで複数条件下で行を別シートにコピーしたい

質問

http://okwave.jp/qa4730673.html
上記URLに検索文字列が１つの場合の物がありますが、
このINPUTBOXを複数にしたい場合、また、検索条件はORで、
別シートにコピーしたいのですが、可能でしょうか？

あらかじめ、複数の検索条件をセルに用意してって物は可能ですが、
InputBoxを使いたいと思ってます。

どなかた、ご教示頂けませんでしょうか？

回答No.4

merlionXX · ベストアンサー

> 3万行程度ありまして、スピードUPさせることは可能でしょうか？

多少は変わるかと思いますが

Sub test02()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range
Dim myStr, ra, rr, myAr
myStr = InputBox("部分一致検索する文字を入力します。" _
& vbNewLine & "複数の場合、/（半角スラッシュ）で区切ってください。", "　(´^∇^)σ　入力してください", "")
If myStr = "" Then
MsgBox "検索文字未指定", vbCritical, "　Σ（￣ロ￣lll)"
Exit Sub
Else
myAr = Split(myStr, "/")
MsgBox Join(myAr, "と") & " を検索します。"
End If
Set ws1 = Sheets("Sheet1") '検索　シート
Set ws2 = Sheets("Sheet2") '貼付先シート
With ws1.Columns("A") '部分一致で検索（A列）
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = LBound(myAr) To UBound(myAr)
Set rng = .Find(What:=myAr(i), LookAt:=xlPart, After:=.Cells(.Cells.Count))
If rng Is Nothing Then 'なかったら
MsgBox myAr(i) & " はありません", vbCritical, myStr & "？　(￣～￣;)う～ん　　"
Else 'あったら
ra = rng.Address '最初に見つかったセルアドレス
Do
rr = rr + 1 'カウント
rng.EntireRow.Copy Destination:=ws2.Cells(rr, 1) '行のコピペ
Set rng = .FindNext(rng) '連続検索
Loop While rng.Address <> ra '繰り返し
Set rng = Nothing
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End With
If rr > 0 Then
MsgBox rr & "件をSheet2に抽出しました。", vbInformation, " （￣ー￣）v"
End If
Set ws1 = Nothing
Set ws2 = Nothing
End Sub

では？

お礼

有難うございました。

補足

merlionXXさん、感謝感謝です。
5秒程度速くなりました。
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
これって、効果あるんですね。
勉強になりました。
有難うございました。

回答No.3

end-u

失礼。
>With ws.Range("E2")
>　　.Range("A1", .End(xlDown)).ClearContents
>　　.Resize(n).Value = y
>End With
以下に修正要です。

With ws.Range("E2")
　　ws.Range(.Item(1), .End(xlDown)).ClearContents
　　.Resize(n).Value = y
End With

回答No.2

end-u

最近、同じくqa4730673.htmlを参考にした質問がありました。（qa5024853.html）
また似たような解法ですみませんが、フィルタオプションを使うと楽です。

>あらかじめ、複数の検索条件をセルに用意してって物は可能です...
可能ならそうしたほうが良いと思います。
が、一応InputBoxを使ってみます。

Sub テストシート作成()
　　With Sheets.Add
　　　　.Range("A1:E1").Value = Array("F1", "F2", "F3", , "F1")
　　　　With .Range("A2:C30000")
　　　　　　.Formula = "=CHAR(48+INT(RAND()*75))"
　　　　　　.Value = .Value
　　　　End With
　　End With
End Sub
...↑この中身はあまりお気になさらず。単にテスト環境を作るコードです。

できたシートをアクティブにして以下実行です。
Sub test()
　　Dim ws As Worksheet
　　Dim n　As Long
　　Dim x　As String
　　Dim y

　　x = InputBox("とりあえず検索語を , で区切ってください")
　　If Len(x) = 0 Then Exit Sub
　　Set ws = ActiveSheet
　　y = Application.Transpose(Split(x, ","))
　　n = UBound(y)
　　With ws.Range("E2")
　　　　.Range("A1", .End(xlDown)).ClearContents
　　　　.Resize(n).Value = y
　　End With
　　ws.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
　　　　　　　　　　　　　　　　　　　　　　　　CriteriaRange:=ws.Range("E1").Resize(n + 1), _
　　　　　　　　　　　　　　　　　　　　　　　　CopyToRange:=Sheets.Add.Range("A1")

　　Set ws = Nothing
End Sub

>Set ws = ActiveSheet
この箇所で検索対象シートを指定していますから応用する場合はここを修正。
検索条件はE列にセットするようになっています。

検索結果書き出しシートを変更する場合は
>CopyToRange:=Sheets.Add.Range("A1")
ここを修正。
CopyToRange:=Sheets("SheetX").Range("A1")
みたく修正してください。

回答No.1

merlionXX

ご提示のURLで回答したmerlionXXです。
複数文字列を、OR条件ということはどちらかでもヒットすれば対象にするんですね？
INPUTBOXを複数回出すのもなんですので、こんな感じではどうでしょう？

Sub test01()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range
Dim myStr, ra, rr, myAr
myStr = InputBox("部分一致検索する文字を入力します。" _
& vbNewLine & "複数の場合、/（半角スラッシュ）で区切ってください。", "　(´^∇^)σ　入力してください", "")
If myStr = "" Then
MsgBox "検索文字未指定", vbCritical, "　Σ（￣ロ￣lll)"
Exit Sub
Else
myAr = Split(myStr, "/")
MsgBox Join(myAr, "と") & " を検索します。"
End If
Set ws1 = Sheets("Sheet1") '検索　シート
Set ws2 = Sheets("Sheet2") '貼付先シート
With ws1.Columns("A") '部分一致で検索（A列）

For i = LBound(myAr) To UBound(myAr)
Set rng = .Find(What:=myAr(i), LookAt:=xlPart, After:=.Cells(.Cells.Count))
If rng Is Nothing Then 'なかったら
MsgBox myAr(i) & " はありません", vbCritical, myStr & "？　(￣～￣;)う～ん　　"
Else 'あったら
ra = rng.Address '最初に見つかったセルアドレス
Do
rr = rr + 1 'カウント
rng.EntireRow.Copy Destination:=ws2.Cells(rr, 1) '行のコピペ
Set rng = .FindNext(rng) '連続検索
Loop While rng.Address <> ra '繰り返し
Set rng = Nothing
End If
Next i
End With
If rr > 0 Then
MsgBox rr & "件をSheet2に抽出しました。", vbInformation, " （￣ー￣）v"
End If
Set ws1 = Nothing
Set ws2 = Nothing
End Sub

お礼

merlionXXさん

大変有難うございました。

補足

merlionXXさん
回答のほう、どうも有難うございます。
質問に追加なんですが、処理が列毎だから、遅くなってしまいますでしょうか？

3万行程度ありまして、スピードUPさせることは可能でしょうか？