半角全角を区別してマクロで指定範囲のコピー&ペーストを行いたいです

今、2つのExcelのブックがあります。ブックBのB列には、

※(行目)|文字列

1|あいうえお
2|あいうえお
3|あいうえお
4|かきくけこ
5|かきくけこ
6|かきくけこ
7|(空白セル)
8|さしすせそ
9|さしすせそ
10|たちつてと



のようなデータが。
ブックAのZ列には、

1|あいうえお
2|あいうえお
3|(空白セル)
4|かきくけこ
5|かきくけこ
6|さしすせそ
7|さしすせそ
8|さしすせそ
9|たちつてと



のようなデータが入ってます。
この状況で、重複や空白セルは無視し、ブックB・B列の“最後の該当データ”(上記の場合3行目、6行目、9行目)と、ブックA・Z列の“最初の該当データ”(上記の場合1行目、4行目、6行目、9行目)が一致した時。

ブックB・B列“最後の該当データ”のK~O列のデータをコピーして。(①)
ブックA・Z列“最初の該当データ”から右に12(AL列)、下に1セル移動した箇所のセルに、①の文字列を貼り付けたいのです。(AL列~AP列に貼り付けることになります)

マクロでもし出来れば助かります。よろしくお願い致します。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2016/04/18 02:08:11
  • 終了:2016/04/18 20:40:21

ベストアンサー

id:a-kuma3 No.1

a-kuma3回答回数4412ベストアンサー獲得回数18032016/04/18 14:23:35

ポイント1800pt

以下のコードをブックA の標準モジュールに貼り付けて、サブルーチンの先頭の変数 ref_book_filename にブックB のファイル名をフルパスで設定してください。
そして、set_data4 サブルーチンを実行してください。

Sub set_data4()
    ref_book_filename = "d:\foo\bar.xlsx"   ' 参照先の Book (フルパス)
    ref_key_column = 2                      ' B列
    ref_value_column = 11                   ' K列
    search_column = 26                      ' Z列
    write_column = search_column + 12       ' AL列

    Set this_book = ActiveWorkbook
    Set this_sheet = ActiveSheet
    Set ref_book = Workbooks.Open(ref_book_filename)

    ' 別シートの値を読み込む
    Set ref_sheet = ref_book.Sheets(1)  ' ひとつめのシート
    last_row = ref_sheet.Cells(Rows.Count, ref_key_column).End(xlUp).Row

    Set Map = CreateObject("Scripting.Dictionary")
    For r = last_row To 1 Step -1
        Set cell = ref_sheet.Cells(r, ref_key_column)
        If Not IsEmpty(cell) And Not cell.Value = "" Then
            If Not Map.Exists(cell.Value) Then
                Map.Add cell.Value, r
            End If
        End If
        DoEvents
    Next


    this_book.Activate
    this_sheet.Activate

    ' 対象シートから探して、値を書き込む
    last_row = Cells(Rows.Count, search_column).End(xlUp).Row
    For r = 1 To last_row
        Set cell = Cells(r, search_column)
        If Not IsEmpty(cell) And Not cell.Value = "" Then
            ref_r = Map.Item(cell.Value)
            If Not IsEmpty(ref_r) Then
                ref_sheet.Range( _
                    ref_sheet.Cells(ref_r, ref_value_column), _
                    ref_sheet.Cells(ref_r, ref_value_column + 4)).Copy _
                        Range(Cells(r + 1, write_column), Cells(r + 1, write_column + 4))
                Map.Remove cell.Value
            End If
        End If
        DoEvents
    Next

    Set Map = Nothing

    ref_book.Close
    Set ref_book = Nothing

End Sub
  • ブックA の Z列の値が、ブックB の B列から見つからない場合には、何もしません
  • ブックA の Z列で、離れた位置に同じ値があった場合には、行場号の小さい方の AL~AP列に貼り付けます

質問の文面では冒頭に「半角全角を区別して」とありますが、特に気にしなくて良いですよね?

id:moon-fondu

はい、問題なく貼り付けできました!ありがとうございました(^^;)

2016/04/18 20:40:05

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

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

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

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

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