VBA 複数行の検索及び抽出

Question

現在VBAで検索用のコードを書いています。
以下のような場合はどのようにコードを書けば良いのかわかりません。

＜例＞
A列　B列　C列　…　K列
　　　1　　a
青　　2 　　b
(☆)　3 　　c
------------------
赤 　　4 　　d
 (◎) 　 5 　　e
------------------


「青」と検索したら、B列、C列の該当する行も抽出したいです。
逆に「c」と検索したら、A列の「青」に該当するすべての行を抽出したいです

前任の担当者がこのようにA列すべてに特殊な書き方でデータを入力していたため、抽出がうまくいきません。（データが９００行近くあり、A列のデータを訂正する作業はやりたくない…）
「青」の下の（）内には住所が記載してあります。「青」の上のセルは空白です。
データによってはB列の中身が８個あったり空白だったり、C列も同様です。


Private Sub 検索_Click()

  Dim last As Long
     
  If 検索テキストボックス.Text = "" Then
    MsgBox "検索したい名を入力してください。"
    Exit Sub
  End If
   
  last = Range("A1000").End(xlUp).Row
  
  Range("A1:k" & last).AutoFilter Field:=4, Criteria1:="=*" & 検索テキストボックス.Text & "*"

End Sub

ここまでは作成済みです。
何か良い案をご教示ください。

googoo900 · Accepted Answer

No.7です。

マクロが一部コピペできていませんでした。こちらに差し替えください。

Sub border()
Dim brdr As border
Dim i As Long
Dim end_row As Long
Dim prev As Long
Dim str_a As String
prev = 2        '***　データ開始行
end_row = Cells(Rows.Count, 2).End(xlUp).Row
For i = prev To end_row
　Cells(i, 1).Select
　Set brdr = Cells(i, 1).Borders(xlEdgeBottom)
　If brdr.LineStyle = xlLineStyleNone Then
　　str_a = str_a + Cells(i, 1)
　Else
　　Range(Cells(prev, 1), Cells(i, 1)) = str_a
　　prev = i + 1
　　str_a = ""
　End If
Next i
End Sub

googoo900 · Answer

>いっそすべてデータを入力し直した方が良い気もしてきました…。

自分なら、上記をやります。
ということで、勝手ながらA列のデータを修正するマクロを作成しました。
こちらに関しては質問者さんの要望が具体的に書いてあったわけではないので、自分ならこうする、というものになっています。微妙に違うところは修正ください。(サポートはします)

1行目は見出し行、2行目以降にデータがあり、区切りの罫線はA列を含んだ列にあり、B列はデータ最下行まで埋まっているという前提です。
マクロを実行すると、罫線で区切られた範囲にあるA列の文字をつなぎ合わせて、その範囲のA列すべてに貼り付けます。
こうすることにより、エクセルのフィルタ機能を使えば、質問者さんのやりたいことは達成できると思います。

◆マクロ実行例
1行目　A列　　B列　C列　…　K列
2行目　青(☆)　1　　a
3行目　青(☆)　2　　b
4行目　青(☆)　3　　c
　　　------------------
5行目　赤(◎)　4　　d
6行目　赤(◎)　5　　e
　　　------------------

念のため、データファイルのコピーを取っておいてください。
◆マクロ（標準モジュールに貼り付けてください）
Dim i As Long
Dim end_row As Long
Dim prev As Long
Dim str_a As String
prev = 2      　　　　　　  '***　データ開始行：実際のデータにあわせる　***
end_row = Cells(Rows.Count, 2).End(xlUp).Row
For i = prev To end_row
　Set brdr = Cells(i, 1).Borders(xlEdgeBottom)
　If brdr.LineStyle = xlLineStyleNone Then
　　str_a = str_a + Cells(i, 1)
　Else
　　Range(Cells(prev, 1), Cells(i, 1)) = str_a
　　prev = i + 1
　　str_a = ""
　End If
Next i
End Sub

PS
罫線内の範囲を抽出する場合にも応用できると思います。

Qchan1962 · Answer

＃４です

>罫線で区切られたデータなので、罫線内の範囲を抽出できる形が理想（？）です
良く読んでいませんでした。。
であれば、＃４のコードを追加、変更して

Dim 罫線 As String　"--------------"はString型変数で
罫線 = "--------------"　　 '-----数合わせて（コピペなどで）一定でなければうまくいかない（違う書き方になります）

If j <> 0 And UBound(Split(r.Value, 罫線)) <> 0 Then
　tmp = Split(r, 罫線)
　aryA = Split(Cells(TrgR, i), 罫線)
を変更

出力時
　 If TrgR <> chek Then
　　 For i = 1 To 3 'ABC列　　要　変更
　　　aryA = Split(Cells(TrgR, i), 罫線)
　　　Ans = Replace(aryA(Trg), vbLf, " ") '半角スペース後で邪魔になるかも知れませんが。位置によりはじめ、最後、前後、などに入ります。
　　Debug.Print Ans '各値を出力（抽出　
　　Next
TrgR = chek '複数列にした場合の重複回避
　 End If

罫線の無いセルへの対応は工夫してみてください。
的外れならすみません。

ママチャリ · Answer

こんなのはどうでしょう。抽出ではなく、該当しない行を非表示にしてみました。
極力、質問主さんが書いたコードを流用していますが、ユーザフォーム（テキストボックス）を作るのが面倒くさかったので、コンスタント値にしています。ここは書き換えて下さい。
どうしても抽出がよければ、シート丸ごと可視セルのみコピーして、別シートに張り付けで、いけると思います。

Sub 検索_Click()
    Dim 検索テキストボックス As String
    検索テキストボックス = "青"
    
    Dim last As Long

If 検索テキストボックス = "" Then
        MsgBox "検索したい名を入力してください。"
        Exit Sub
    End If

last = Range("A1000").End(xlUp).Row
    
    Dim s As Long
    Dim i As Long
    s = 1
    For i = 1 To last
        If Cells(i, "A").Borders(xlEdgeBottom).LineStyle <> xlLineStyleNone Then
            If Rows(s & ":" & i).Find(What:=検索テキストボックス, After:=Cells(i, 1), LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , MatchByte:=False, SearchFormat:=False) Is Nothing Then
                Rows(s & ":" & i).Hidden = True
            End If
            s = i + 1
        End If
    Next
End Sub

Qchan1962 · Answer

>いっそすべてデータを入力し直した方が良い気もしてきました…。多分、作り直した方が良いと思いますね。セル内の文字列条件などがあり、明確ならVBAでシート自体作り直すことも出来るかと、、これは別の話でした。セル内の文字列に対してキーワードを抽出する事は出来ると思いますので、 vbLfをカウントしてセル内行数を算出するとかになるのでしょうか？、、処理も大変になると思いますし、、。 VBAで作り直すにしてもプロセスは、同じような形になるのかな？勝手な条件をこちらで設定して参考コード？を書いてみました。セル内に改行がない場合は検出されません。（書き足せば出来ますが、とりあえず） A列を検索対象にしています。変更してください。細かい検証はしていません。セル内のキーワード重複も考えていません。 Private Sub 検索_Click() 　　Dim i As Long, j As Long 　　Dim last As Long, Trg As Long, TrgR As Long, chek As Long 　　Dim r As Range 　　Dim Search As String 　　Dim tmp, aryA 　　If 検索テキストボックス.Text = "" Then 　　　　MsgBox "検索したい名を入力してください。" 　　　　Exit Sub 　　End If 　　last = Range("A1000").End(xlUp).Row 　　Range("A1:k" & last).AutoFilter Field:=4, Criteria1:="=*" & 検索テキストボックス.Text & "*" 　　'可視セルのA列のみにしたので要変更　　Range(Range("A2"), Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Select 　　Search = "xxxx"　　'サーチワード　TextBoxなどで　　On Error Resume Next 　　For Each r In Selection 　　　　j = InStr(r.Value, Search) 　　　　If j <> 0 And UBound(Split(r.Value, vbLf)) <> 0 Then 　　　　　　tmp = Split(r, vbLf) 　　　　　　For j = 0 To UBound(tmp) 　　　　　　　　If InStr(tmp(j), Search) > 0 Then　’曖昧　含まれていれば実行されるので　＝　で結ぶ方が良いかも？　If tmp(j)=Search Then 　　　　　　　　　　Trg = j 　　　　　　　　　　TrgR = r.Row 　　　　　　　　　　Exit For 　　　　　　　　End If 　　　　　　Next 　　　　End If 　　　　If TrgR <> chek Then 　　　　　　For i = 1 To 3　　'ABC列　　要　変更　　　　　　　　aryA = Split(Cells(TrgR, i), vbLf) 　　　　Debug.Print aryA(Trg)　 '各値を出力（抽出　　　　　　Next 　　　　　　TrgR = chek　　'複数列にした場合の重複回避　　　　End If 　　Next End Sub

めぐみん_ · Answer

No.2です。

＞いっそすべてデータを入力し直した方が良い気もしてきました…。

その方が逆に楽かもですね。
毎度毎度やる訳じゃないですし。

めぐみん_ · Answer

罫線って厄介ですね。
どうせなら結合セルにしてくれれば良かったようにも思えます。

fujillin · Answer

こんにちは

すみませんが、回答ではありません。

どうやら、複数行（可変長）でひとつのデータセットになっているようですが、そのセットの区切りはどのようにして判断できるのかについての説明がまったく無いので手の付けようがないと思われます。

また、列を指定しての単純な検索でヒットしたものをそのまま採用しても良いのかどうかも不明です。
（列を指定できるのかも不明ですが。）
つまり、検索値と同じ値がデータ内に存在する可能性がないかということで、もしもそのような可能性があり得るのなら、検索対象とするセルを限定した上で検索しないと、余分なデータまでヒットしかねないからです。

私が回答できるかどうかはわかりませんが、他の方が回答するにしても、上記のあたりが不明のままでは回答できないのではと思いますので。

VBA 複数行の検索及び抽出

No.7です。

>いっそすべてデータを入力し直した方が良い気もしてきました…。

＃４です

こんなのはどうでしょう。

>いっそすべてデータを入力し直した方が良い気もしてきました…。

No.2です。

罫線って厄介ですね。

こんにちは

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング