VLOOKUP関数のようなもので部分一致する行を複数、抽出したい


今、Sheet1のA列に次のようなデータが1000行ほど並んでいます。
(左側の数字は何行目かを示しています)

1|りんご
10|ごりら
20|らっぱ
30|らくだ
40|マンボウ




そしてSheet2のA列には、以下のような文章のデータが1000行ほど並んでいます。

1|おはよう
2|美味しいりんごを食べた
3|会いにいきます
4|ごりらに会いました
5|朝かららっぱを練習
6|またごりらに会った
7|またりんごを食べた




この状態におきまして。

回答の条件
  • 1人10回まで
  • 登録:
  • 終了:2020/01/14 18:51:28
id:moon-fondu

Sheet1のF列のセルに、関数か何かを入れまして、

F列

1|美味しいりんごを食べた

2|またりんごを食べた

10|ごりらに会いました

11|またごりらに会った

20|朝かららっぱを練習

30|(空白セル)

40|(空白セル)

と、Sheet1のA列の各行に記載のセルの文字列に、部分一致するSheet2のA列のデータを全て表示したいのです。

もちろん、他の方法でも構いません。何かしらの方法で、Sheet1の各行の文字列に一致する、Sheet2のデータを複数抽出できないかと悩んでおります…。

複数のデータを貼り付けないといけない場合を想定しまして、Sheet1には敢えて、空白行を入れています。(上記例の場合、2~9、11~19、21~29、31~39行目)Sheet2から抽出した行のデータが複数行あれば、Sheet1のF列にも複数行、記載しないといけないと思いましたので。

お力添えいただけますと幸いです。よろしくお願いします<m(__)m>

ベストアンサー

id:Z1000S No.3

回答回数39ベストアンサー獲得回数27

ポイント1000pt
Public Sub copyFilteredDatas()

    Dim rDatasHD    As Range
    Dim rDatasD     As Range
    Dim rResult     As Range
    Dim lDataCount  As Long
    Dim lRow    As Long
    Dim sKey    As String

    Application.ScreenUpdating = False

    With Sheet2
        'オートフィルター用ダミーヘッダ追加
        .Rows(1).Insert
        .Range("A1").Value = "DummyHead"

        'データ取得元(ヘッダー含む)
        Set rDatasHD = Sheet2.Range("A1").CurrentRegion

        'データ取得元(ヘッダー含まず)
        Set rDatasD = rDatasHD.Resize(rDatasHD.Rows.Count - 1).Offset(1)

        'データ件数
        lDataCount = rDatasD.Rows.Count
    End With

    lRow = 1

    If rDatasHD.Parent.AutoFilterMode Then
        'オートフィルター解除
        rDatasHD.AutoFilter
    End If

    Do Until lRow = Sheet1.Rows.Count
        'フィルターキー
        sKey = Sheet1.Range("A" & CStr(lRow)).Value
        sKey = "*" & sKey & "*"

        If rDatasHD.Parent.FilterMode Then
            'オートフィルタークリア
            rDatasHD.Parent.ShowAllData
        End If

        'オートフィルター
        rDatasHD.AutoFilter Field:=1, Criteria1:=sKey

        If rDatasHD.SpecialCells(xlCellTypeVisible).Count > 1 Then
            '可視セルのみ
            Set rResult = rDatasD.SpecialCells(xlCellTypeVisible)

            'コピー
            rResult.Copy Sheet1.Range("F" & CStr(lRow))
        End If

        '次のキー行(連続した行入力には非対応)
        lRow = Sheet1.Range("A" & CStr(lRow)).End(xlDown).Row
    Loop

    If rDatasHD.Parent.AutoFilterMode Then
        'オートフィルター解除
        rDatasHD.AutoFilter
    End If

    'ダミーヘッダー削除
    Sheet2.Rows(1).Delete

    Application.ScreenUpdating = True

End Sub
id:moon-fondu

ありがとうございます、うまく結果が出てきました!

2020/01/14 18:50:05

その他の回答2件)

id:huumm No.1

回答回数8ベストアンサー獲得回数2

ポイント950pt
Sub KeyFilter()

'Sheet1 配列Key に書き込み
Dim i As Long, c As Long, s As Long, Key() As String

Sheets("Sheet1").Range("A:A").AutoFilter 1, "<>"

s = 1
c = WorksheetFunction.Subtotal(3, Range("A:A"))

ReDim Key(s To c)

For i = 1 To Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Row
 If Sheets("Sheet1").Cells(i, 1) <> "" Then
  Key(s) = Sheets("Sheet1").Cells(i, 1)
  s = s + 1
 End If
Next i

Sheets("Sheet1").Range("A:A").AutoFilter

'F列に書き出し
Dim k As Long, x As Long, y As Long

y = 1
Sheets("Sheet1").Cells(1, 1).Activate

For x = 1 To UBound(Key)
 
  For k = 1 To Sheets("Sheet2").Cells(Rows.count, 1).End(xlUp).Row
   
   If InStr(Sheets("Sheet2").Cells(k, 1), Key(x)) <> 0 Then
   Sheets("Sheet1").Cells(y, 6) = Sheets("Sheet2").Cells(k, 1)
   y = y + 1
   End If
  
  Next k
 
 If x = UBound(Key) Then Exit For
  
 y = ActiveCell.End(xlDown).Row
 Sheets("Sheet1").Cells(y, 1).Activate
 
Next x

End Sub


↑できてるか分かりません。
シート2の文章一覧に見出しをつけてフィルターを使えば、もっと簡単にできそうだなと思いました。

id:moon-fondu

すごいです、うまく求めたいデータが出てきてくれました!ありがとうございます(^^;)

2020/01/14 18:49:25
id:AichiKaoru No.2

回答回数180ベストアンサー獲得回数37

ポイント200pt

 
moonエクセルファイルを作成しました。
シート1の列Aには、1行目、11行目、21行目、31行目、...に
データを入れました。
次のURLから、moonエクセルファイルをダウンロードすることができます。
https://firestorage.jp/download/ab3df7bd5bd16d5070165484892d70cdf18617a6
 
moonエクセルファイルの規則に倣って、1000行まで、
 
シート2に関数式を入力します。
 
シート3に値コピー貼り付けしてから、
 
シート3の列Bを基準にして、降順の並べ替えを行います。
 
シート1の列Cに、vlookup関数を用いて、結果を並べます。
 
以上で求めるデータを得ることができます。
 
 
 

id:moon-fondu

すごいですね…あとはSheet1の重複データを消すと何とかなりそうですね。
関数とセル操作だけでも実現できるんですね、ありがとうございます!

2020/01/14 18:49:47
id:Z1000S No.3

回答回数39ベストアンサー獲得回数27ここでベストアンサー

ポイント1000pt
Public Sub copyFilteredDatas()

    Dim rDatasHD    As Range
    Dim rDatasD     As Range
    Dim rResult     As Range
    Dim lDataCount  As Long
    Dim lRow    As Long
    Dim sKey    As String

    Application.ScreenUpdating = False

    With Sheet2
        'オートフィルター用ダミーヘッダ追加
        .Rows(1).Insert
        .Range("A1").Value = "DummyHead"

        'データ取得元(ヘッダー含む)
        Set rDatasHD = Sheet2.Range("A1").CurrentRegion

        'データ取得元(ヘッダー含まず)
        Set rDatasD = rDatasHD.Resize(rDatasHD.Rows.Count - 1).Offset(1)

        'データ件数
        lDataCount = rDatasD.Rows.Count
    End With

    lRow = 1

    If rDatasHD.Parent.AutoFilterMode Then
        'オートフィルター解除
        rDatasHD.AutoFilter
    End If

    Do Until lRow = Sheet1.Rows.Count
        'フィルターキー
        sKey = Sheet1.Range("A" & CStr(lRow)).Value
        sKey = "*" & sKey & "*"

        If rDatasHD.Parent.FilterMode Then
            'オートフィルタークリア
            rDatasHD.Parent.ShowAllData
        End If

        'オートフィルター
        rDatasHD.AutoFilter Field:=1, Criteria1:=sKey

        If rDatasHD.SpecialCells(xlCellTypeVisible).Count > 1 Then
            '可視セルのみ
            Set rResult = rDatasD.SpecialCells(xlCellTypeVisible)

            'コピー
            rResult.Copy Sheet1.Range("F" & CStr(lRow))
        End If

        '次のキー行(連続した行入力には非対応)
        lRow = Sheet1.Range("A" & CStr(lRow)).End(xlDown).Row
    Loop

    If rDatasHD.Parent.AutoFilterMode Then
        'オートフィルター解除
        rDatasHD.AutoFilter
    End If

    'ダミーヘッダー削除
    Sheet2.Rows(1).Delete

    Application.ScreenUpdating = True

End Sub
id:moon-fondu

ありがとうございます、うまく結果が出てきました!

2020/01/14 18:50:05

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません