１の表の値を２表から探してその隣列の値を３表へ貼付

質問

なかなかうまくできないため、もう少し詳しくかきます。
表画像は細かいので貼りつけません。excel2007

(1)book1.の表の値を
(2)book2.の表の中から見つけて、その隣の列の値を
(3)book3.の表の該当する箇所にふりがな表記の縦書きにして貼付けます。
book1.sheet1 B3から下方に英数字の値が1000行程度羅列しています。
例）a243,a546,b124...
その値をbook2.sheet1 A列の中から見つけ、
その隣B列の値"文字列"を
book3.sheet1の表の該当箇所に、
ふりがな表記の縦書きにして貼付けます。
book3.の表は、A2:Y2 までの列に25,24,23,22,...1と
A5:Y5の列に50,49,48...26と数字が左から右に並んでいて、
このA2:Y7で１グルーブになり、Z2に"A1グループ"となっています。
このグループが下方に"A1グループ"～"A8グループ"　８グループあるというような表です。
ちなみに"A2グループ"はA8:Y13というぐあいです。
このAグループがsheet1に,sheet2にはBグループが同じ表であります。
例）book1でa243という値は最終的にbook3のA2グループの43のセルの2つ下H13に
(2)(3)という方法で貼付けます。
b124という値はbook3 sheet2　Bグループの表”B1グループ"の24のセルの2つ下B:4に貼付けられます。

よろしくお願いします。

回答No.1

keithin · ベストアンサー

sub macro1()
dim h1 as range
dim h2 as range
dim h3 as range

on error resume next
workbooks("Book1.xlsx").select　’ファイルの拡張子を確認し適切に修正すること。以下同文。漏れなく行うこと。
worksheets("Sheet1").select

for each h1 in range("B3:B" & range("B65536").end(xlup).row)
set h2 = workbooks("Book2.xlsm").worksheets("Sheet1").range("A:A").find(what:=h1.value, lookin:=xlvalues, lookat:=xlpart).offset(0, 1)

set h3 = workbooks("Book3.xlsm").worksheets(iif(left(h1.value,1)="a","Sheet1", "Sheet2")).range("Z:Z").find(what:=left(h1.value, 2), lookin:=xlvalues, lookat:=xlpart).resize(6,1).entirerow.find(what:=val(right(h1.value, 2)),lookin:=xlvalues, lookat:=xlwhole).offset(2)

with h3
.value = h2.value
.setphonetic
.orientation = xlvertical
.phonetics.visible = true
end with

next
end sub

お礼

すばらしい！！
できてます。できてます。
ありがとうございます。
さっそく使ってみます。