エクセルのsheet1にあるデータを参照してsheet2からsheet8にあるB列のキーに合致する行にB列C列のデータをsheet2からsheet8のH列I列にコピーするマクロをお願いします。
参照データ
sheet1
A列 B列 C列
AAAA 10 3500
BBBB 50 5300
データ行は2行目からです
コピー先
sheet2からsheet8
B列 H列 I列
AAAA 10 3500
BBBB 50 5300
CCCC
データ行は2行目からです。
よろしくお願いします。
>コピー元のA列のコードがコピー先のB列のコードと合致したものが
>コピー元のB列C列のデータを
>コピー先のsheet2からsheet8のH列I列へコピーできるよう変更できまか
この部分はそのままだと思います。
名前を変更できるようした変更は
Sub Macro2() '開始行 Const stRow As Integer = 2 Dim i As Long Dim j As Integer Dim lastRow As Long Dim obj As Object Dim ws1 As Worksheet Dim ws2 As Worksheet Dim h As Variant 'デフォルトではSheet1は大文字で始まりますが、質問分のようにsheet1にしている場合は合わせてください。 Set ws1 = Worksheets("Sheet1") 'シート名は任意ということで以下を変更してください h = Array("Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7", "Sheet8") lastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row For i = stRow To lastRow For j = 0 To UBound(h) Set ws2 = Worksheets(h(j)) Set obj = ws2.Range("B:B").Find(ws1.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole) If Not obj Is Nothing Then ws1.Range(ws1.Cells(i, "B"), ws1.Cells(i, "C")).Copy ws2.Cells(obj.Row, "H") End If Next Next i End Sub
Sub Macro2() '開始行 Const stRow As Integer = 2 Dim i As Long Dim j As Integer Dim lastRow As Long Dim obj As Object Dim ws1 As Worksheet Dim ws2 As Worksheet 'デフォルトではSheet1は大文字で始まりますが、質問分のようにsheet1にしている場合は合わせてください。 Set ws1 = Worksheets("Sheet1") lastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row For i = stRow To lastRow For j = 2 To 8 Set ws2 = Worksheets("Sheet" & j) Set obj = ws2.Range("B:B").Find(ws1.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole) If Not obj Is Nothing Then ws1.Range(ws1.Cells(i, "B"), ws1.Cells(i, "C")).Copy ws2.Cells(obj.Row, "H") End If Next Next i End Sub
ありがとうございます。
申し訳ありませんが
コピー元のA列のコードがコピー先のB列のコードと合致したものが
コピー元のB列C列のデータを
コピー先のsheet2からsheet8のH列I列へコピーできるよう変更できまか
またその名前も変更できるようにお願いしたいのですが
もし再質問になるようでしたら再度質問をあげます。
>コピー元のA列のコードがコピー先のB列のコードと合致したものが
>コピー元のB列C列のデータを
>コピー先のsheet2からsheet8のH列I列へコピーできるよう変更できまか
この部分はそのままだと思います。
名前を変更できるようした変更は
Sub Macro2() '開始行 Const stRow As Integer = 2 Dim i As Long Dim j As Integer Dim lastRow As Long Dim obj As Object Dim ws1 As Worksheet Dim ws2 As Worksheet Dim h As Variant 'デフォルトではSheet1は大文字で始まりますが、質問分のようにsheet1にしている場合は合わせてください。 Set ws1 = Worksheets("Sheet1") 'シート名は任意ということで以下を変更してください h = Array("Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7", "Sheet8") lastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row For i = stRow To lastRow For j = 0 To UBound(h) Set ws2 = Worksheets(h(j)) Set obj = ws2.Range("B:B").Find(ws1.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole) If Not obj Is Nothing Then ws1.Range(ws1.Cells(i, "B"), ws1.Cells(i, "C")).Copy ws2.Cells(obj.Row, "H") End If Next Next i End Sub
ありがとうございました。
なかなかマクロがきかなかったのですが
何回かやっているうち最後にうまくゆきました。
ありがとうございまし。
ありがとうございました。
なかなかマクロがきかなかったのですが
何回かやっているうち最後にうまくゆきました。
ありがとうございまし。