今、2つのExcelのブックがあります。ブックBのM列には、空白セルとデータが混じってます。


※(行目)|文字列

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



ブックAのR列には、

1|(空白セル)
2|あいうえおについて
3|あいうえおです
4|かきくけこの発声練習
5|かきくけこについて
6|(空白セル)
7|さしすせその勉強
8|(空白セル)
9|さしすせそについて



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

前回も似たような質問をさせていただいた http://q.hatena.ne.jp/1458366868 ので、応用しようとしたのですが空白セルが上書きされてしまったりと、どうもうまくいきませんでしたので。再度よろしくお願い致します。

回答の条件
  • 1人10回まで
  • 登録:2017/08/13 14:19:26
  • 終了:2017/08/20 18:01:33

ベストアンサー

id:a-kuma3 No.2

a-kuma3回答回数4624ベストアンサー獲得回数19592017/08/16 23:42:24

ポイント1750pt

昔のことは記憶の遥か彼方ですが、こんな感じではどうでしょう。

Sub set_data()
    ref_book_filename = "d:\foo\bar.xlsx"   ' 参照先の Book (フルパス)
    ref_column = 13                         ' M列
    search_column = 18                      ' R列
    write_column = search_column + 28       ' AT列

    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
            If Not map.Exists(cell.Value) Then
                Map.Add cell.Value, cell.Value
            End If
        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

上記のコードをブックA の標準モジュールに貼り付けて、set_data サブルーチンを実行します。

ブックA の方が、こういう結果になれば良いんですよね?

 |(R)                         |(AT)
1|(空白セル)                |
2|あいうえおについて          |
3|あいうえおです              |あいうえお
4|かきくけこの発声練習        |
5|かきくけこについて          |かきくけこ
6|(空白セル)                |
7|さしすせその勉強            |
8|(空白セル)                |さしすせそ
9|さしすせそについて          |
・

「空白セルが上書きされてしまったり」というのは、ぼくもよく分かりませんでした。

id:moon-fondu

ありがとうございます、うまく貼り付けられました!
助かりました~(^^♪

2017/08/20 18:00:44

その他の回答(1件)

id:gfik No.1

いつか回答回数18ベストアンサー獲得回数102017/08/16 07:40:02

ポイント150pt

a-kuma3さんのは正常に動くと思いますし、
「空白セルが上書きされてしまったり」は再現されないので。
想像での返答になりますが。

ブックAの複数データに丸1を記述したいという質問なら
下から8行目(空行含めると10行目)の
Exit For
を消してみてください。

id:moon-fondu

ありがとうございます、少しコードが間違っていたのかもしれません。

2017/08/20 17:59:55
id:a-kuma3 No.2

a-kuma3回答回数4624ベストアンサー獲得回数19592017/08/16 23:42:24ここでベストアンサー

ポイント1750pt

昔のことは記憶の遥か彼方ですが、こんな感じではどうでしょう。

Sub set_data()
    ref_book_filename = "d:\foo\bar.xlsx"   ' 参照先の Book (フルパス)
    ref_column = 13                         ' M列
    search_column = 18                      ' R列
    write_column = search_column + 28       ' AT列

    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
            If Not map.Exists(cell.Value) Then
                Map.Add cell.Value, cell.Value
            End If
        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

上記のコードをブックA の標準モジュールに貼り付けて、set_data サブルーチンを実行します。

ブックA の方が、こういう結果になれば良いんですよね?

 |(R)                         |(AT)
1|(空白セル)                |
2|あいうえおについて          |
3|あいうえおです              |あいうえお
4|かきくけこの発声練習        |
5|かきくけこについて          |かきくけこ
6|(空白セル)                |
7|さしすせその勉強            |
8|(空白セル)                |さしすせそ
9|さしすせそについて          |
・

「空白セルが上書きされてしまったり」というのは、ぼくもよく分かりませんでした。

id:moon-fondu

ありがとうございます、うまく貼り付けられました!
助かりました~(^^♪

2017/08/20 18:00:44

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

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

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

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

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