部分一致したら、一致したデータと隣のセルの2つのデータを、一致したセルの隣の2列にまたがる空白セルに貼り付けていきたい


今、ExcelファイルにSheet1、Sheet2があり。
Sheet1のA列には、以下のようなデータが5万行ぐらいあります。

※(行目)|文字列

1|ddcccりんごaaab
2|ddeりんごaaa
3|aaaaごりらあdee
4|aaaらっこsbes


そしてSheet2のC列にも5万行ぐらい、以下のようなデータが入っています。

1|りんご
2|らくだ
3|ごりら
4|らっこ
5|ライオン



こういった状況におきまして。
もしSheet2のC列のキーワードが、Sheet1のA列のセルに含まれていた場合。
その隣の空白にしておいたSheet1のB列とC列のセルへ。
一致したSheet2のC列のキーワードのセルと、その隣にあるD列のセルをコピーして。
Sheet1の一致したA列のセルの隣のB列とC列に、貼り付けていきたいのです。

そのような処理がマクロで可能でしたらお教えいただけないでしょうか。
よろしくお願い致します。

回答の条件
  • 1人10回まで
  • 13歳以上
  • 登録:2016/07/06 07:57:32
  • 終了:2016/07/09 04:31:35

ベストアンサー

id:a-kuma3 No.1

a-kuma3回答回数4367ベストアンサー獲得回数18032016/07/06 15:40:01

ポイント1500pt

標準モジュールに以下のコードを貼り付けて、Sheet1 を表示している状態で put_by_keyword_list サブルーチンを実行してください。

Sub put_by_keyword_list()
    On Error GoTo ErrorHandler

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim keyword()

    Set ref_s = Sheets("Sheet2")

    ' C列の最終行を調べる
    max_kwd = ref_s.Cells(Rows.Count, 3).End(xlUp).Row

    ReDim keyword(max_kwd)
    For r = 1 To max_kwd
        keyword(r) = ref_s.Cells(r, 3).Value
    Next

    ' A列の最終行を調べる
    last_row = Cells(Rows.Count, 1).End(xlUp).Row

    r = 2
    Do While r <= last_row
        txt = Cells(r, 1).Value
        For i = 1 To max_kwd
            If InStr(txt, keyword(i)) > 0 Then
                Cells(r, 2).Value = ref_s.Cells(i, 3).Value
                Cells(r, 3).Value = ref_s.Cells(i, 4).Value
                Exit For
            End If
            DoEvents
        Next
        r = r + 1
    Loop

FINAL:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    Exit Sub

ErrorHandler:
    GoTo FINAL

End Sub

Sheet2 のキーワードが入っている C 列には空白のセルがないことを前提にしています。
また、複数のキーワードがヒットするデータの場合には、先に見つかった(Sheet2 で行番号が若い)キーワードの行の C列と D列を複写します。

特別に速くはない数年前のノートPC で、キーワードが 50000件、対象のデータが 55000件、Sheet2 のキーワードがひとつもヒットしないデータが 170件ほどあるテストデータで試したところ、17分20秒ほどかかりました (´・ω・`)

激しく時間がかかるため、値のコピーにはクリップボードを使う Copy メソッドを使いませんでした(*1)。値だけを複写の対象として、セルの書式などは複写していません(やろうと思えばできます)。
 

*1:このマクロを動かしている間、クリップボードが空にされるため、他の作業をやりながら、というわけにいかなくなってしまいます

id:moon-fondu

遅くなりましてすみません。試してみたことろ、うまく貼り付けができました!
ありがとうございます(^^♪

2016/07/09 04:28:43

その他の回答(1件)

id:a-kuma3 No.1

a-kuma3回答回数4367ベストアンサー獲得回数18032016/07/06 15:40:01ここでベストアンサー

ポイント1500pt

標準モジュールに以下のコードを貼り付けて、Sheet1 を表示している状態で put_by_keyword_list サブルーチンを実行してください。

Sub put_by_keyword_list()
    On Error GoTo ErrorHandler

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim keyword()

    Set ref_s = Sheets("Sheet2")

    ' C列の最終行を調べる
    max_kwd = ref_s.Cells(Rows.Count, 3).End(xlUp).Row

    ReDim keyword(max_kwd)
    For r = 1 To max_kwd
        keyword(r) = ref_s.Cells(r, 3).Value
    Next

    ' A列の最終行を調べる
    last_row = Cells(Rows.Count, 1).End(xlUp).Row

    r = 2
    Do While r <= last_row
        txt = Cells(r, 1).Value
        For i = 1 To max_kwd
            If InStr(txt, keyword(i)) > 0 Then
                Cells(r, 2).Value = ref_s.Cells(i, 3).Value
                Cells(r, 3).Value = ref_s.Cells(i, 4).Value
                Exit For
            End If
            DoEvents
        Next
        r = r + 1
    Loop

FINAL:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    Exit Sub

ErrorHandler:
    GoTo FINAL

End Sub

Sheet2 のキーワードが入っている C 列には空白のセルがないことを前提にしています。
また、複数のキーワードがヒットするデータの場合には、先に見つかった(Sheet2 で行番号が若い)キーワードの行の C列と D列を複写します。

特別に速くはない数年前のノートPC で、キーワードが 50000件、対象のデータが 55000件、Sheet2 のキーワードがひとつもヒットしないデータが 170件ほどあるテストデータで試したところ、17分20秒ほどかかりました (´・ω・`)

激しく時間がかかるため、値のコピーにはクリップボードを使う Copy メソッドを使いませんでした(*1)。値だけを複写の対象として、セルの書式などは複写していません(やろうと思えばできます)。
 

*1:このマクロを動かしている間、クリップボードが空にされるため、他の作業をやりながら、というわけにいかなくなってしまいます

id:moon-fondu

遅くなりましてすみません。試してみたことろ、うまく貼り付けができました!
ありがとうございます(^^♪

2016/07/09 04:28:43
id:lovevoiceryu No.2

lovevoiceryu回答回数5ベストアンサー獲得回数12016/07/06 23:57:26

ポイント10pt

データ件数と処理内容からExcelではなくAccess向きだと思いました。
もちろんExcelマクロでも可能ですが、Accessの方が容易、かつ高速に処理できると思います。

id:moon-fondu

そうなんですか!Accessは使ったことないんですよ~。おすすめの方法がありましたら、またお願いします。

2016/07/09 04:31:09
  • id:takashi_m17
    Sheet2のキーワードが複数入ることは想定しなくて良いのでしょうか。
    たとえば、Sheet1の文字列が「aaaりんごりらっこaaa」のような場合です。「りんご」なのか「ごりら」なのか「らっこ」なのか

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

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

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

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません