質問です。

エクセルの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行目からです。
よろしくお願いします。

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2011/05/14 10:22:10
  • 終了:2011/05/14 15:13:24

ベストアンサー

id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692011/05/14 13:29:26

ポイント35pt

>コピー元の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
id:inosisi4141

ありがとうございました。

なかなかマクロがきかなかったのですが

何回かやっているうち最後にうまくゆきました。

ありがとうございまし。

2011/05/14 15:11:50

その他の回答(1件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692011/05/14 11:00:44

ポイント35pt
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
id:inosisi4141

ありがとうございます。

申し訳ありませんが

コピー元のA列のコードがコピー先のB列のコードと合致したものが

コピー元のB列C列のデータを

コピー先のsheet2からsheet8のH列I列へコピーできるよう変更できまか

またその名前も変更できるようにお願いしたいのですが

もし再質問になるようでしたら再度質問をあげます。

2011/05/14 12:54:47
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692011/05/14 13:29:26ここでベストアンサー

ポイント35pt

>コピー元の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
id:inosisi4141

ありがとうございました。

なかなかマクロがきかなかったのですが

何回かやっているうち最後にうまくゆきました。

ありがとうございまし。

2011/05/14 15:11:50
  • id:SALINGER
    シート名なのですが、3つ目の質問のように任意の場合は、
    3つ目の回答のような変更が必要になります。
  • id:inosisi4141
    ありがとうございます。
    了解しました。
    またなにかありましたら質問します。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません