[[20190108133443]]　『指定した文字列を含む行とその周辺の行を一括で抽』（クロウ）　ページの最後に飛ぶ

『指定した文字列を含む行とその周辺の行を一括で抽出したい』（クロウ）

指定した複数の文字列のいずれかを含むセルがある行とその周辺の行を抽出したいです。
例えば

－－－－－－－－－－－－－－－－－－－－－－－－－－
りんご　　　　　　　　　1
　　　　　　　　　　　　2
　　　　　　　　　　　　3
－－－－－－－－－－－－－－－－－－－－－－－－－－
みかん　　　　　　　　　1
　　　　　　　　　　　　2
－－－－－－－－－－－－－－－－－－－－－－－－－－
ばなな　　　　　　　　　1
　　　　　　　　　　　　2
　　　　　　　　　　　　3
　　　　　　　　　　　　4
　　　　　　　　　　　　5
－－－－－－－－－－－－－－－－－－－－－－－－－－
なし　　　　　　　　　　1
　　　　　　　　　　　　2
　　　　　　　　　　　　3
　　　　　　　　　　　　4
－－－－－－－－－－－－－－－－－－－－－－－－－－
もも　　　　　　　　　　1
－－－－－－－－－－－－－－－－－－－－－－－－－－
みかん　　　　　　　　　1
　　　　　　　　　　　　2
　　　　　　　　　　　　3
　　　　　　　　　　　　4
－－－－－－－－－－－－－－－－－－－－－－－－－－
りんご　　　　　　　　　1
　　　　　　　　　　　　2
　　　　　　　　　　　　3
　　　　　　　　　　　　4
－－－－－－－－－－－－－－－－－－－－－－－－－－

このような表があった場合、りんごとみかんの文字列を指定して

－－－－－－－－－－－－－－－－－－－－－－－－－－
りんご　　　　　　　　　1
　　　　　　　　　　　　2
　　　　　　　　　　　　3
－－－－－－－－－－－－－－－－－－－－－－－－－－
みかん　　　　　　　　　1
　　　　　　　　　　　　2
－－－－－－－－－－－－－－－－－－－－－－－－－－
みかん　　　　　　　　　1
　　　　　　　　　　　　2
　　　　　　　　　　　　3
　　　　　　　　　　　　4
－－－－－－－－－－－－－－－－－－－－－－－－－－
りんご　　　　　　　　　1
　　　　　　　　　　　　2
　　　　　　　　　　　　3
　　　　　　　　　　　　4
－－－－－－－－－－－－－－－－－－－－－－－－－－

このような結果になるようにしたいです。
どのような機能を使えば良いでしょうか？宜しくおねがいします。

＜使用 Excel：Excel2016、使用 OS：Windows8 ＞

 空白セルを全部埋めた方が早いと思いますけど、その方向は如何でしょうか？
（コナミ） 2019/01/08(火) 14:10

Sub main()
'Sheet1からSheet2に抽出
'指定文字列はＡ列

    Dim dic As Object, c As Range, r As Range, flg As Boolean
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Sheet2")
        .Cells.ClearContents
        Sheets("Sheet1").Cells.Copy .Range("A1")
        Do
            ip = InputBox("文字列を指定してください。" & vbLf & "指定終了した場合はそのままＯＫボタン")
            If ip = "" Then Exit Do
            dic(ip) = True
        Loop
        For Each c In .UsedRange.Resize(, 1)
            If Trim(c.Value) <> "" Then
                If dic(c.Value) Then
                    flg = True
                Else
                    flg = False
                End If
            End If
            If Not flg Then c.EntireRow.Hidden = True
        Next c
        Set r = .Cells.SpecialCells(12)
        .Cells.EntireRow.Hidden = False
        r.EntireRow.Hidden = True
        .Cells.SpecialCells(12).Delete
        .Cells.EntireRow.Hidden = False
    End With
End Sub
（mm） 2019/01/08(火) 14:21

コナミさま
コメントありがとうございます。
空白セルを全部埋めた方が早いとはどういうことでしょうか？
知識不足ですみません。

mmさま
ありがとうございます！
かなり近いことが出来ました。
1つ質問なのですが、文字列指定のポップアップが出たときにこの画面で複数の文字列を指定する方法はありますでしょうか？
"りんご","みかん"のようにして1回で複数の文字列を指定する方法がありましたら教えていただきたいです。
わがまま言ってすみません。
（クロウ） 2019/01/08(火) 17:21

Sub main()
'Sheet1からSheet2に抽出
'指定文字列はＡ列

    Dim dic As Object, p As Variant, c As Range, r As Range, flg As Boolean
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Sheet2")
        .Cells.ClearContents
        Sheets("Sheet1").Cells.Copy .Range("A1")
        ip = InputBox("文字列を指定してください（カンマ区切りで複数指定可）。")
        For Each p In Split(Trim(Replace(ip, "、", ",")), ",")
        dic(p) = True
        Next p
        For Each c In .UsedRange.Resize(, 1)
            If Trim(c.Value) <> "" Then
                If dic(c.Value) Then
                    flg = True
                Else
                    flg = False
                End If
            End If
            If Not flg Then c.EntireRow.Hidden = True
        Next c
        Set r = .Cells.SpecialCells(12)
        .Cells.EntireRow.Hidden = False
        r.EntireRow.Hidden = True
        .Cells.SpecialCells(12).Delete
        .Cells.EntireRow.Hidden = False
    End With
End Sub
（mm） 2019/01/09(水) 11:00

mmさん
完璧です！ありがとうございます！
（クロウ） 2019/01/09(水) 14:06

 コナミさんの言う空白セルを埋めるというのは

 1.A3セルからA24セルを選択 → F5キーを押す → セル選択で「空白セル」を選択
 2.その状態で数式バーに =A2
 3.Ctrlキーを押しながらEnterキーを押す

 ということです。3の後にホームタブにあるフォントの色から白を選択すれば
 空白セルのように見せかけることもできます。
（bi） 2019/01/09(水) 14:25

biさん
ありがとうございます。
とても参考になりました。

mmさん
先日はありがとうございました。
ただ、また問題が起きてしまいました。
今回の質問で作成したりんご、みかん…のデータではうまくいったのですが、実際のデータでやると途中で途切れたりかなり飛び飛びで抽出されたりしてしまいました。
3000件ほどある中から1000件ほど抽出する必要があるのですが、抽出できる数に限りがあるのでしょうか？どうやら10～20項目ぐらいまでしか抽出できていないようでした。
度々質問して申し訳ありません。

（クロウ） 2019/01/10(木) 11:01

先程自分で色々試してみたのですが、りんご・みかん・ばななのようなリストだとうまく抽出されたのですが、会社名、書籍名のようなものになると抽出できませんでした。

例えばこれは書籍の高価買取リストなのですが

－－－－－－－－－－－－－－－－－－－－－－－－－－
戦略的ブランド・マネジメント
伝説のコピーライティング実践バイブル
マーケティング入門
ゲーム理論　新版
ザ・マーケティング　実践篇
グラッサー博士の選択理論
アントレプレナーの戦略思考技術
ハーバード流「21世紀経営」4つのコントロール・レバー
ピーター・ドラッカー　マーケターの罪と罰
経営戦略全史
レビットのマーケティング思考法
訴訟リスクを劇的にダウンさせる就業規則の考え方、作り方。
ビジネスモデル全史 (ディスカヴァー・レボリューションズ)
リーダーの言葉が届かない10の理由単行本
ひと目でわかる! 図解日本アムウェイ(改訂第2版)
大手企業から引っ張りだこの超人気講師が教える研修講師養成講座
メンバーの才能を開花させる技法 (単行本（ソフトカバー）)
ビジョナリー・カンパニー 2 - 飛躍の法則
稼ぐ会社の「課長心得12カ条
－－－－－－－－－－－－－－－－－－－－－－－－－－

このようなリストがあった場合、このリストをSheet1にコピペし、メモ帳などで横並びに直してカンマで区切ったものを入力ボックスにコピペしてOKすると、なぜか
ハーバード流「21世紀経営」4つのコントロール・レバー
のところまでしか抽出されません。

区切って入力できる件数に限りがあるのかと思ったのですが、りんご・みかん・ばなな・のような簡単なものだと20件ほど抽出できたのでそこもよくわかりません。
うまく抽出できない原因、また他に抽出方法がありましたらご教示願います。よろしくおねがいします。

（クロウ） 2019/01/10(木) 17:04

’文字数制限では

Sub MAIN()

IP = InputBox("", , WorksheetFunction.Rept("A", 1000))

MsgBox "文字数制限 max：" & Len(IP)

End Sub
（mm） 2019/01/11(金) 09:51

mmさん

ありがとうございます。
ということはやはり大量の文字列で抽出することは出来ないのでしょうか？
mmさんのコードでは文字数制限 max：254とでたので、それ以上の文字列は抽出出来ないということですかね。
（クロウ） 2019/01/11(金) 12:09

 空白セルを埋めておけば、フィルタオプションでできますね。
（コナミ） 2019/01/11(金) 12:16

'別案
Sub main2()
'Sheet1からSheet2に抽出
'指定文字列はＡ列

    Dim dic As Object, dic2 As Object, k As Variant, p As Variant, c As Range, r As Range, flg As Boolean
    Set dic = CreateObject("scripting.dictionary")
    Set dic2 = CreateObject("scripting.dictionary")   
    With Sheets("Sheet2")
        .Cells.ClearContents
        Sheets("Sheet1").Cells.Copy .Range("A1")
        For Each c In .UsedRange.Resize(, 1).SpecialCells(2)
            dic2(c.Value) = True
        Next c
        For Each k In dic2
            If MsgBox(k & "　を指定しますか", 36) = 6 Then
                dic(k) = True
            End If
        Next k
        For Each c In .UsedRange.Resize(, 1)
            If Trim(c.Value) <> "" Then
                If dic(c.Value) Then
                    flg = True
                Else
                    flg = False
                End If
            End If
            If Not flg Then c.EntireRow.Hidden = True
        Next c
        Set r = .Cells.SpecialCells(12)
        .Cells.EntireRow.Hidden = False
        r.EntireRow.Hidden = True
        .Cells.SpecialCells(12).Delete
        .Cells.EntireRow.Hidden = False
    End With
End Sub

（mm） 2019/01/11(金) 15:37

コナミさん
有難うございます。
試してみますね。

mmさん
有難うございます。
試してみたのですが、項目を一つ一つポップアップさせてOKを押す形式は項目が1000以上あるので少し厳しいかもしれません。申し訳ないです。

やはりmmさんが前に書いてくれた

Sub main()
'Sheet1からSheet2に抽出
'指定文字列はＡ列

    Dim dic As Object, p As Variant, c As Range, r As Range, flg As Boolean
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Sheet2")
        .Cells.ClearContents
        Sheets("Sheet1").Cells.Copy .Range("A1")
        ip = InputBox("文字列を指定してください（カンマ区切りで複数指定可）。")
        For Each p In Split(Trim(Replace(ip, "、", ",")), ",")
        dic(p) = True
        Next p
        For Each c In .UsedRange.Resize(, 1)
            If Trim(c.Value) <> "" Then
                If dic(c.Value) Then
                    flg = True
                Else
                    flg = False
                End If
            End If
            If Not flg Then c.EntireRow.Hidden = True
        Next c
        Set r = .Cells.SpecialCells(12)
        .Cells.EntireRow.Hidden = False
        r.EntireRow.Hidden = True
        .Cells.SpecialCells(12).Delete
        .Cells.EntireRow.Hidden = False
    End With
End Sub

というInputBoxにカンマで区切って文字列を入力し、一括で抽出する方法が一番良かったのですが文字数制限があるとは。残念です。
（クロウ） 2019/01/11(金) 16:05

Sub main3()

   If MsgBox("指定した複数の文字列を、Sheet3 のＡ列１行目から下方向にセットしてください。" & vbLf & "準備はよろしいですか？", 36) = 7 Then Exit Sub
    Dim dic As Object, c As Range, r As Range, flg As Boolean
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Sheet2")
        .Cells.ClearContents
        Sheets("Sheet1").Cells.Copy .Range("A1")
        For Each c In Sheets("Sheet3").Range("A:A").SpecialCells(2)
            dic(c.Value) = True
        Next c
        For Each c In .UsedRange.Resize(, 1)
            If Trim(c.Value) <> "" Then
                If dic(c.Value) Then
                    flg = True
                Else
                    flg = False
                End If
            End If
            If Not flg Then c.EntireRow.Hidden = True
        Next c
        Set r = .Cells.SpecialCells(12)
        .Cells.EntireRow.Hidden = False
        r.EntireRow.Hidden = True
        .Cells.SpecialCells(12).Delete
        .Cells.EntireRow.Hidden = False
    End With
End Sub
（mm） 2019/01/11(金) 16:46

mmさん
有難うございます！
今度こそ出来ました！
もしかしたらまた何かお聞きすることがあるかもしれませんが、今の所は希望通りの動作をしています。
本当に色々とお世話になりました。自分でもこのようなものが作れるよう、もっと精進したいと思います。
（クロウ） 2019/01/11(金) 17:09

コメント返信：

[ 一覧(最新更新順) ]

[[20190108133443]] 『指定した文字列を含む行とその周辺の行を一括で抽』（クロウ） ページの最後に飛ぶ

[[20190108133443]]　『指定した文字列を含む行とその周辺の行を一括で抽』（クロウ）　ページの最後に飛ぶ