今、2つのExcelのブックがあります。

ブックBのK列には、空白セルとデータが混じってます。

※(行目)|文字列

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



ブックAのZ列には、

1|あいうえおのこと
2|あいうえおについて
3|あいうえおです
4|かきくけこの発声練習
5|かきくけこについて
6|さしすせそです
7|さしすせその勉強
8|さしすせそのアクセント
9|さしすせそについて



のようなデータが入ってます。
この状況にて。
ブックBのK列の空白セルは無視し、データのあるセルの文字列(①とします)を1つずつ、ブックAのZ列にあるかどうか探します。(ブックAのZ列のセルとは完全一致しなくてもよいです)
そして、一致した場合は。
一致した“最初の該当データ”から右に13(AM列)、下に1セル移動した箇所のセルに、①の文字列を貼り付けたいのです。そのような処理が出来るマクロ等お教えいただけないでしょうか。

※”最初の該当データ”とは、今回の例でいいますと、

1|あいうえおのこと
4|かきくけこの発声練習
6|さしすせそです

になります。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2016/03/19 14:54:28
  • 終了:2016/03/21 09:32:24

ベストアンサー

id:a-kuma3 No.1

a-kuma3回答回数4366ベストアンサー獲得回数18022016/03/19 16:54:28

ポイント1500pt

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

Sub set_data()
    ref_book_filename = "d:\foo\bar.xlsx"   ' 参照先の Book (フルパス)
    ref_column = 11                         ' K列
    search_column = 26                      ' Z列
    write_column = search_column + 13       ' AM列

    Set this_book = ActiveWorkbook
    Set ref_book = Workbooks.Open(ref_book_filename)
    this_book.Activate

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

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

    ref_book.Close
    Set ref_book = Nothing

    ' 対象シートから探して、値を書き込む
    last_row = Cells(Rows.Count, search_column).End(xlUp).Row
    For Each Key In Map.keys
        Debug.Print Key
        For r = 1 To last_row
            If InStr(Cells(r, search_column).Value, Key) > 0 Then
                Cells(r + 1, write_column).Value = Key
                Exit For
            End If
            DoEvents
        Next
    Next

    Set Map = Nothing

End Sub

ブックB のどのシートにデータが入っているかが書いてなかったので、最初のシートから K列の値を読み込むようにしています。

以下のことを前提としています。

  • ブックB の K列に入ってる値は重複していない。
  • ブックA の Z列に入っているブックB の K列の値は近くにかたまっていて、離れたところには存在しない。
  • ブックA の Z列は、部分一致で探します。
    「あいうえお」は、「ここにもあいうえお」にもマッチします。

二番目の前提は、こういうことです。

1|あいうえおのこと
2|あいうえおについて       あいうえお
3|あいうえおです
4|かきくけこの発声練習
5|かきくけこについて       かきくけこ
6|さしすせそです
7|さしすせその勉強         さしすせそ
8|さしすせそのアクセント
9|さしすせそについて
    ...
100|また、あいうえお       ※ここには、「あいうえお」は書かれない
他1件のコメントを見る
id:a-kuma3

実行時エラー"457"
このキーは既にこのコレクションの要素に割り当てられています。

それは、ブックB の K列に重複したデータがあります。
値を入れているデータに重複がないのが確実であれば、空白に見えて全角の空白が入ってたり、とかないでしょうか。

重複していた場合に無視するようにもできます。

    Set Map = CreateObject("Scripting.Dictionary")
    For r = 1 To last_row
        Set cell = ref_sheet.Cells(r, ref_column)
        If Not IsEmpty(cell) And Not cell.Value = "" Then
            If Not map.Exists(cell.Value) Then      ' ここを追加
                Map.Add cell.Value, cell.Value
            End If                                  ' ここを追加
        End If
        DoEvents
    Next

意図していない重複かもしれないので、一応 データの確認もしてみてください。

2016/03/19 22:10:58
id:moon-fondu

重複ありました…ですが、a-kuma3さんの重複無視の方のコードで稼働させてみると、うまく貼り付けができました!ありがとうございました(^^;)

2016/03/21 09:31:43

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

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

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

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

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