bookBから2列にまたがるデータを引用して、bookAに正しいデータを貼り付けたい(Excel)

bookAで、AT列にある重複データ(例えば「りんごごりら」など)を検索します。該当するセルに来ましたら、左に5列(AO列)、下に1セル移動した場所のセルをコピーします。(①とします)

次にbookBのG列において①の文字列を検索し、完全一致する該当セルがありましたら。そのセルから上に、データのあるセルは無視し最初の空白セルのある場所まで移動(最初の空白セルでストップ)し、更に右に5列移動(L列)します。そしてL列のセルと、隣のM列のセル、2つのセルをコピーします。(②とします)

最後にbookAのAO列において①の文字列を完全一致で検索をかけ、該当セルに来ましたら。そこから上に空白セルのある場所まで移動し、該当の空白セルから更に右に5列移動した場所に、②を貼り付けます。(AT列、AU列のセルに貼り付け)

こういった処理を6万行ぐらい行いたいのですが、かなり複雑な動きであるとは思います。ですがもし自動化が可能であれば…お教えいただけますと幸いです。

よろしくお願い致します<m(__)m>

回答の条件
  • 1人10回まで
  • 13歳以上
  • 登録:2017/10/14 22:46:57
  • 終了:2017/10/21 19:58:29

ベストアンサー

id:a-kuma3 No.1

a-kuma3回答回数4739ベストアンサー獲得回数20322017/10/16 22:49:02

ポイント2000pt

下記のマクロを bookA の標準モジュールにはりつけて、copy_data サブルーチンを実行してください。

Const REF_BOOK = "D:\data\bookB.xlsx"   ' bookB のフルパス

Function is_blank_cell(c)
    is_blank_cell = IsEmpty(c) Or c.Value = ""
End Function

Sub copy_data()
    search_word = "りんごごりら"
    target_column = 46              ' AT列
    ref_column = 7                  ' G列

    Set this_book = ActiveWorkbook
    Set bookB = Workbooks.Open(REF_BOOK)
    this_book.Activate
    Set ref_sheet = bookB.Sheets(1)     ' bookB の 1番目のシート

    last_row = Cells(Rows.Count, target_column).End(xlUp).Row
    last_row_b = ref_sheet.Cells(Rows.Count, ref_column).End(xlUp).Row

    last_blank_row = -1
    last_blank_row_b = -1

    For r = 1 To last_row
        If is_blank_cell(Cells(r, target_column - 5)) Then
            last_blank_row = r
        End If
        If InStr(Cells(r, target_column).Value, search_word) > 0 Then
            Key = Cells(r + 1, target_column - 5).Value
            rr = -1
            For r2 = 1 To last_row_b
                If is_blank_cell(ref_sheet.Cells(r2, ref_column)) Then
                    last_blank_row_b = r2
                End If
                If ref_sheet.Cells(r2, ref_column).Value = Key Then
                    rr = last_blank_row_b
                    Exit For
                End If
                DoEvents
            Next
            If last_blank_row <> -1 And rr <> -1 Then
                Set s_range = ref_sheet.Range(ref_sheet.Cells(rr, ref_column + 5), ref_sheet.Cells(rr, ref_column + 6))
                rd = last_blank_row
                Set d_range = Range(Cells(rd, target_column), Cells(rd, target_column + 1))
                s_range.Copy d_range
            End If
        End If
        DoEvents
    Next
    bookB.Close SaveChanges:=False
    MsgBox "FINISH !"
End Sub

今回も、分レベルの処理時間がかかりそうなので、終わったらメッセージボックスを表示するようにしてみました。

一応、テストデータを作って試してはみましたが、実物で試していないので、題意を汲み取れているか不安なところはあります。
# まあ、人力検索だとやり取りが第三者に見えてしまうので、実物をもらうのは厳しいところですが。

id:moon-fondu

遅くなりましてすみません、ありがとうございます、うまくいきました(^^♪

2017/10/21 19:57:53

コメントはまだありません

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

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

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

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