※(行目)|文字列
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 ので、応用しようとしたのですが空白セルが上書きされてしまったりと、どうもうまくいきませんでしたので。再度よろしくお願い致します。
昔のことは記憶の遥か彼方ですが、こんな感じではどうでしょう。
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|さしすせそについて | ・
「空白セルが上書きされてしまったり」というのは、ぼくもよく分かりませんでした。
a-kuma3さんのは正常に動くと思いますし、
「空白セルが上書きされてしまったり」は再現されないので。
想像での返答になりますが。
ブックAの複数データに丸1を記述したいという質問なら
下から8行目(空行含めると10行目)の
Exit For
を消してみてください。
ありがとうございます、少しコードが間違っていたのかもしれません。
昔のことは記憶の遥か彼方ですが、こんな感じではどうでしょう。
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|さしすせそについて | ・
「空白セルが上書きされてしまったり」というのは、ぼくもよく分かりませんでした。
ありがとうございます、うまく貼り付けられました!
助かりました~(^^♪
ありがとうございます、うまく貼り付けられました!
2017/08/20 18:00:44助かりました~(^^♪