338

view

---補足に対して---
どれに対しての補足なのか分かりませんが・・・
指定した順番でソートするようにコードを入替しました。
現コードでは、花,山,森の付くもの順にソートします。
いろんなやり方がありますが、ここでは、手動でも使えるように振り仮名を使用しています。
従って、振り仮名表示は、数値になっています。
たぶん使わないと思うので・・・
ところで検索は、何種類あるんですか？
今は10種まではOKですが、幾らでも増やせますが、推測出来ないので・・・
まぁ、これでどうですか。
---------------

手動でやるなら、フィルタのオプションで「を含む」を指定して抽出し、それをコピーしてソートすればいいだけと思います。
まぁ、もし質問の主旨が、自動で処理したい ということであれば、VBAで処理することになります。
それでも宜しければ、次の手順でテストしてみてください。
一応、コードの設定手順を書いておきます。
１．Alt + F11 で VBE(Visual Basic Editor)を開きます。
２．VBE のメニューから挿入 -->標準モジュール を指定します。
３．コードウィンドウに下記コードをコピーして貼り付けます。
' <--の指定部分を実情に合わせます。
４．Alt + Q （または、右上隅の×）でウィンドウを閉じ、シートに戻ります。
５．メニューからツール-->マクロ-->セキュリティで「セキュリティレベル」を「中」にしてOKします。
６．実行するときは、Alt ＋ F8 (メニューからツール-->マクロ-->マクロ)で「検索抽出」を指定し、実行ボタンを押します。
この例は、Sheet1のA列のデータに"花"と"山"を含む行をSheet2に抽出し、検索文字の「指定した順」でソートしています。


Sub 検索抽出()
Dim FRng As Range
Const OrgSh = "Sheet1" ' <-- 基本シート名を指定
Const DesSh = "Sheet2" ' <-- 抽出シート名を指定
Const FindStr = "花,山,森" ' <-- 検索文字列をカンマ区切りで指定
' -------- ここで ↑ 指定した順番でソートします。
Dim Rw As Long
Dim Ary As Variant
Dim Cnt As Integer
Dim Fst As String
Ary = Split(FindStr, ",")
Sheets(OrgSh).Activate
With Sheets(DesSh)
.Cells.ClearContents
Rows(1).Copy .Rows(1)
Rw = 2
For Cnt = 0 To UBound(Ary)
Set FRng = Range("A:A").Find(Ary(Cnt), lookat:=xlPart)
If Not FRng Is Nothing Then
Fst = FRng.Address
Do
Rows(FRng.Row).Copy .Rows(Rw)
.Cells(Rw, 1).Phonetics.Delete
.Cells(Rw, 1).Characters(1).PhoneticCharacters = CStr(Cnt)
Rw = Rw + 1
Set FRng = Range("A:A").FindNext(FRng)
Loop Until FRng.Address = Fst
End If
Next
.Cells.Sort Key1:=.Range("A2"), Order1:=xlAscending, _
Header:=xlYes, SortMethod:=xlPinYin
End With
MsgBox Rw - 2 & " 件のデータを抽出しました。", vbInformation
Set FRng = Nothing
End Sub