【再依頼】 2つブック 条件転記と分岐の方法

質問

いつもこの質問サイトには大変おせわになっております。

2つブック　条件転記と分岐の方法というタイトルで質問させて頂いて
コードのアドバイスを頂いたのですが
本来は元の質問に追記したかったのですが
ベストアンサーを選んだので回答が締め切ってしまったので
一部、やりたいことと相違があったので再度質問させて頂きます

２つのブックがあって

IDデータ表.xlsは
IDと日付が記述されています。

ID管理票のIDの場所はバラバラですが
日付は必ずIDの横３つのどれかに記述されています。

IDデータ表.xlsとID管理票.xlsのIDが一致して
尚且つID管理票.xlsのIDの横３つのセルに日付が入ってるものを上書き
空白のセルは無視する

IDデータ表のB列に取消と入っていたら
ID管理票と合致したIDとその横３つの日付をクリアする。

このマクロで
IDデータ表とID管理票のIDが一致したら
IDデータ表の日付をID管理票に転記するという内容で
With c.Offset(, 1)の命令でIDのすぐ横に記述しています。

この命令をID管理票の元々記述あった日付のセルに上書きしたいのですが
どう変えれば動くでしょうか？
アドバイスの方　よろしくお願いいたします

Sub TEST()
Dim w0 As Worksheet, w1 As Worksheet
Dim i As Long, c As Range

Set w0 = Workbooks("IDデータ表.xls").Worksheets("大元")
Set w1 = Workbooks("ID管理票.xls").Worksheets("管理")
For i = 2 To w0.Cells(Rows.Count, "A").End(xlUp).Row
Set c = w1.Cells.Find(what:=w0.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
If w0.Cells(i, "B") <> "取消" Then

With c.Offset(, 1)
.Value = w0.Cells(i, "B")
.NumberFormatLocal = "m/d"
End With

Else
c.Resize(, 4).ClearContents
End If
End If
Next i
End Sub

回答No.1

keithin · ベストアンサー

＞日付は必ずIDの横３つのどれかに記述されています。

これが絶対に保証されている前提でチェックを省きます。

sub macro1()
　dim w0 as worksheet, w1 as worksheet
　dim h as range, Target as range

　set w0 = workbooks("IDデータ表.xls").worksheets("大元")
　set w1 = workbooks("ID管理表.xls").worksheets("管理")

　for each h in w0.range("A2:A" & w0.range("A65536").end(xlup).row)
　　set target = w1.cells.find(what:=h.value, lookin:=xlvalues, lookat:=xlwhole)

　　if not target is nothing and h.offset(0, 1) <> "" then
　　　if h.offset(0, 1).value = "取消" then
　　　　target.resize(1, 4).clearcontents
　　　else
　　　　target.offset(0, 1).resize(1, 3).specialcells(xlcelltypeconstants) = h.offset(0, 1).value
　　　end if
　　end if

　next
end sub

お礼

>これが絶対に保証されている前提でチェックを省きます。

決まった書式ですので問題ありません
返答遅くなり申し訳ありません

無事、動きました！！！
ありがとうございます