[昨日挙げた回答]
前の質問
yahoo.co.jp/qa/question_detail/q12321550532">https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q12321550532
これとはまた別の内容なのですか？
違うとしても、画像の赤枠はセルアドレス（行と列）がわかりません。
行番号と列が見える表を添付して下さい。
条件は10個限定でいいのかが不明です。
返信がなかったので条件の表は、こちらで添付したものとしてのコ－ドです。
転記先データは先頭行の数字だけにして下さい。～を使うと数が違う懸念があります。（貴方の添付図の2件目は元が16行で、先が15行になっています）
転記元の列の情報がないので、日付と同じ列としています。
Sub test()
Dim wb1 As Workbook, wb2 As Workbook
Dim sh As Worksheet
Dim sh1 As Worksheet, sh2 As Worksheet
Dim r As Long
Dim dcol As String
Dim r1 As Long, r2 As Long
Dim r3 As Long, r4 As Long
Dim rng As Range
Dim c As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sh = ActiveSheet
With sh
For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If .Cells(r, 1).Value \u0026lt;\u0026gt; \u0026quot;\u0026quot; Then
Set wb1 = Workbooks.Open(.Cells(r, 2).Value \u0026amp; .Cells(r, 1).Value)
Set sh1 = wb1.Worksheets(.Cells(r, 3).Value)
Set wb2 = Workbooks.Open(.Cells(r, 8).Value \u0026amp; .Cells(r, 7).Value)
Set sh2 = wb2.Worksheets(.Cells(r, 9).Value)
dcol = Left(.Cells(r, 4).Value, 1)
r1 = Split(.Cells(r, 5).Value, \u0026quot;～\u0026quot;)(0)
r2 = Split(.Cells(r, 5).Value, \u0026quot;～\u0026quot;)(1)
r3 = .Cells(r, 10).Value
r4 = .Cells(r, 11).Value
Set rng = sh2.Range(sh2.Cells(r3, 1), sh2.Cells(r3, sh2.Cells(r3, Columns.Count).End(xlToLeft).Column))
c = Application.Match(CLng(sh1.Range(.Cells(r, 4).Value)), rng, 0)
If IsError(c) = False Then
sh2.Cells(r4, c).Resize(r2 - r1 + 1, 1).Value = sh1.Range(dcol \u0026amp; r1).Resize(r2 - r1 + 1, 1).Value
End If
wb1.Close
wb2.Close SaveChanges:=True
End If
Next r
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox \u0026quot;転記終了\u0026quot;
End Sub
前の質問でBAでなかったのでこのコードではだめなのかもしれません。
うまくいかない場合は質問を閉じないでうまくいかない点を連絡して下さい。
※画像はクリックすると拡大されます
