行すべての値を張り付けるようにするには

質問

次の突合用マクロですが、照合番号だけでなく行すべてのデータを張り付けたいのですが、どの部分に変更を加えればよいかわかりません。

（添付画像をご覧ください）
・Sheet3~6にも列B～以降のデータを張り付けたい

EntireRow
Copy
を使おうとしたのですが、どの様に行を指定すればよいかわかりませんでした。

ご教示頂ければ幸いです。

【準備して頂いたマクロ】
Sub TestX()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim Sh3 As Worksheet, Sh4 As Worksheet
Dim Sh5 As Worksheet, Sh6 As Worksheet
Dim Sh1data As Variant, Sh2data As Variant
Dim Sh3data As Variant, Sh4data As Variant
Dim Sh5data As Variant, Sh6data As Variant
Dim Sh1LastRow As Long, Sh2LastRow As Long
Dim i As Long, j As Long, Sh5flg As Boolean

Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
Set Sh3 = Worksheets("Sheet3")
Set Sh4 = Worksheets("Sheet4")
Set Sh5 = Worksheets("Sheet5")
Set Sh6 = Worksheets("Sheet6")

ReDim Sh3data(0)
ReDim Sh4data(0)
ReDim Sh5data(0)
ReDim Sh6data(0)

Sh1LastRow = Sh1.Cells(Rows.Count, "A").End(xlUp).Row
Sh2LastRow = Sh2.Cells(Rows.Count, "A").End(xlUp).Row

Sh1data = Sh1.Range(Sh1.Cells(3, "A"), Sh1.Cells(Sh1LastRow, "B")).Value
Sh2data = Sh2.Range(Sh2.Cells(3, "A"), Sh2.Cells(Sh2LastRow, "B")).Value

For i = 1 To Sh1LastRow - 2
Sh5flg = False
For j = 1 To Sh2LastRow - 2
If Sh1data(i, 1) = Sh2data(j, 1) Then
If Sh2data(j, 2) <> "◯" Then
Sh1data(i, 2) = "◯"
Sh3data(UBound(Sh3data)) = Sh1data(i, 1)
ReDim Preserve Sh3data(UBound(Sh3data) + 1)
Sh2data(j, 2) = "◯"
Else
Sh5data(UBound(Sh5data)) = Sh1data(i, 1)
ReDim Preserve Sh5data(UBound(Sh5data) + 1)
Sh5flg = True
End If
Exit For
End If
Next j
If Sh1data(i, 2) <> "◯" And Sh5flg = False Then
Sh5data(UBound(Sh5data)) = Sh1data(i, 1)
ReDim Preserve Sh5data(UBound(Sh5data) + 1)
End If
Next i
For i = 1 To Sh2LastRow - 2
If Sh2data(i, 2) = "◯" Then
Sh4data(UBound(Sh4data)) = Sh2data(i, 1)
ReDim Preserve Sh4data(UBound(Sh4data) + 1)
Else
Sh6data(UBound(Sh6data)) = Sh2data(i, 1)
ReDim Preserve Sh6data(UBound(Sh6data) + 1)
End If
Next
Sh1.Range("A3").Resize(Sh1LastRow - 2, 2).Value = Sh1data
Sh2.Range("A3").Resize(Sh2LastRow - 2, 2).Value = Sh2data
Sh3.Range("A3").Resize(UBound(Sh3data), 1).Value = WorksheetFunction.Transpose(Sh3data)
Sh4.Range("A3").Resize(UBound(Sh4data), 1).Value = WorksheetFunction.Transpose(Sh4data)
Sh5.Range("A3").Resize(UBound(Sh5data), 1).Value = WorksheetFunction.Transpose(Sh5data)
Sh6.Range("A3").Resize(UBound(Sh6data), 1).Value = WorksheetFunction.Transpose(Sh6data)
Set Sh1 = Nothing
Set Sh2 = Nothing
Set Sh3 = Nothing
Set Sh4 = Nothing
Set Sh5 = Nothing
Set Sh6 = Nothing
End Sub

回答No.4

kkkkkm · ベストアンサー

No2ですが
一致するデータがない時にエラーになりますので
最後の
Sh3.Range("A3").Resize(UBound(Sh3data, 2), UBound(Sh3data, 1) + 1).Value = WorksheetFunction.Transpose(Sh3data)
のところで
UBound(Sh3data, 2)の後ろに+1を追加してください。
Sh3.Range("A3").Resize(UBound(Sh3data, 2) + 1, UBound(Sh3data, 1) + 1).Value = WorksheetFunction.Transpose(Sh3data)
Sh4以下も同じように
Sh4.Range("A3").Resize(UBound(Sh4data, 2) + 1, UBound(Sh4data, 1) + 1).Value = WorksheetFunction.Transpose(Sh4data)
Sh5.Range("A3").Resize(UBound(Sh5data, 2) + 1, UBound(Sh5data, 1) + 1).Value = WorksheetFunction.Transpose(Sh5data)
Sh6.Range("A3").Resize(UBound(Sh6data, 2) + 1, UBound(Sh6data, 1) + 1).Value = WorksheetFunction.Transpose(Sh6data)

お礼

頂きました回答の中で、kkkkkm様のご回答が最も利便性、編集可能性ともに高く
本当に助かりました。
まだまだ頂いたコードの内容すべてを理解できていない自分がふがいなく思いますが、勉強をすすめ改めて感謝させて頂きたくいと思います。
ありがとうございました。

回答No.3

kkkkkm

後から手を加えることを考えたらTest2の方が楽かもしれません。
今回は1列から4列に増えたので.Resize(1, 4)を追加しただけでいけます。

Sub Test2()
Dim c As Range, FRange As Range
Dim Sh1 As Worksheet, Sh2 As Worksheet

Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")

For Each c In Sh1.Range(Sh1.Cells(3, "A"), Sh1.Cells(Rows.Count, "A").End(xlUp))
Set FRange = Sh2.Range(Sh2.Cells(3, "A"), Sh2.Cells(Rows.Count, "A").End(xlUp)). _
Find(c.Value, LookAt:=xlWhole, After:=Sh2.Cells(Rows.Count, "A").End(xlUp))
If Not FRange Is Nothing Then
If c.Value = FRange.Value Then
If FRange.Offset(0, 1).Value <> "◯" Then
c.Offset(0, 1).Value = "◯"
Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, 4).Value = c.Resize(1, 4).Value
FRange.Offset(0, 1).Value = "◯"
Else
Sheets("Sheet5").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, 4).Value = c.Resize(1, 4).Value
End If
End If
Else
Sheets("Sheet5").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, 4).Value = c.Resize(1, 4).Value
End If
Next
For Each c In Sh2.Range(Sh2.Cells(3, "A"), Sh2.Cells(Rows.Count, "A").End(xlUp))
If c.Offset(0, 1).Value = "◯" Then
Sheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, 4).Value = c.Resize(1, 4).Value
Else
Sheets("Sheet6").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, 4).Value = c.Resize(1, 4).Value
End If
Next
Set Sh1 = Nothing
Set Sh2 = Nothing
End Sub

回答No.2

kkkkkm

TestXはセルのデータをシート毎に一度に変数に読み込んで処理した後の変数データをシート毎に一度で書き込むという操作ですので通常のプロパティやメソッドは処理をしているデータにたいしては利用できません。
それぞれ読み込んだデータの先頭から数えて
Sh1data(行目,列目)
Sh2data(行目,列目)
書き込むデータは諸般の事情で
Sh3data(数値+1列目,数値+1行目)
Sh4data(数値+1列目,数値+1行目)
Sh5data(数値+1列目,数値+1行目)
Sh6data(数値+1列目,数値+1行目)
になります。

行数が増えたので一部冗長な部分を省きました。

Sub TestX()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim Sh3 As Worksheet, Sh4 As Worksheet
Dim Sh5 As Worksheet, Sh6 As Worksheet
Dim Sh1data As Variant, Sh2data As Variant
Dim Sh3data() As Variant, Sh4data() As Variant
Dim Sh5data() As Variant, Sh6data() As Variant
Dim Sh1LastRow As Long, Sh2LastRow As Long
Dim i As Long, j As Long, k As Long, Sh5flg As Boolean

Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
Set Sh3 = Worksheets("Sheet3")
Set Sh4 = Worksheets("Sheet4")
Set Sh5 = Worksheets("Sheet5")
Set Sh6 = Worksheets("Sheet6")

ReDim Sh3data(3, 0)
ReDim Sh4data(3, 0)
ReDim Sh5data(3, 0)
ReDim Sh6data(3, 0)

Sh1LastRow = Sh1.Cells(Rows.Count, "A").End(xlUp).Row
Sh2LastRow = Sh2.Cells(Rows.Count, "A").End(xlUp).Row

Sh1data = Sh1.Range(Sh1.Cells(3, "A"), Sh1.Cells(Sh1LastRow, "D")).Value
Sh2data = Sh2.Range(Sh2.Cells(3, "A"), Sh2.Cells(Sh2LastRow, "D")).Value

For i = 1 To Sh1LastRow - 2
Sh5flg = False
For j = 1 To Sh2LastRow - 2
If Sh1data(i, 1) = Sh2data(j, 1) Then
If Sh2data(j, 2) <> "◯" Then
Sh1data(i, 2) = "◯"
For k = LBound(Sh3data, 1) To UBound(Sh3data, 1)
Sh3data(k, UBound(Sh3data, 2)) = Sh1data(i, k + 1)
Next k
ReDim Preserve Sh3data(3, UBound(Sh3data, 2) + 1)
Sh2data(j, 2) = "◯"
End If
Exit For
End If
Next j
If Sh1data(i, 2) <> "◯" Then
For k = LBound(Sh5data, 1) To UBound(Sh5data, 1)
Sh5data(k, UBound(Sh5data, 2)) = Sh1data(i, k + 1)
Next k
ReDim Preserve Sh5data(3, UBound(Sh5data, 2) + 1)
End If
Next i
For i = 1 To Sh2LastRow - 2
If Sh2data(i, 2) = "◯" Then
For k = LBound(Sh4data, 1) To UBound(Sh4data, 1)
Sh4data(k, UBound(Sh4data, 2)) = Sh2data(i, k + 1)
Next k
ReDim Preserve Sh4data(3, UBound(Sh4data, 2) + 1)
Else
For k = LBound(Sh6data, 1) To UBound(Sh6data, 1)
Sh6data(k, UBound(Sh6data, 2)) = Sh2data(i, k + 1)
Next k
ReDim Preserve Sh6data(3, UBound(Sh6data, 2) + 1)
End If
Next
Sh1.Range("A3").Resize(Sh1LastRow - 2, 2).Value = Sh1data
Sh2.Range("A3").Resize(Sh2LastRow - 2, 2).Value = Sh2data
Sh3.Range("A3").Resize(UBound(Sh3data, 2), UBound(Sh3data, 1) + 1).Value = WorksheetFunction.Transpose(Sh3data)
Sh4.Range("A3").Resize(UBound(Sh4data, 2), UBound(Sh4data, 1) + 1).Value = WorksheetFunction.Transpose(Sh4data)
Sh5.Range("A3").Resize(UBound(Sh5data, 2), UBound(Sh5data, 1) + 1).Value = WorksheetFunction.Transpose(Sh5data)
Sh6.Range("A3").Resize(UBound(Sh6data, 2), UBound(Sh6data, 1) + 1).Value = WorksheetFunction.Transpose(Sh6data)
Set Sh1 = Nothing
Set Sh2 = Nothing
Set Sh3 = Nothing
Set Sh4 = Nothing
Set Sh5 = Nothing
Set Sh6 = Nothing
End Sub

回答No.1

Mathmi

もしコピーする列数がn列だと決まっているのなら、

4箇所の
>Sh*data(UBound(Sh3data)) = Sh1data(i, 1)
を
>Sh*data(UBound(Sh3data)) = Sh1data(i, 1).EntireRow
に変更
(末尾にEntireRowを追加)

最後の4箇所の
>Sh*.Range("A3").Resize(UBound(Sh*data), 1).Value = WorksheetFunction.Transpose(Sh*data)
を
>Sh*.Range("A3").Resize(UBound(Sh*data), n).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Sh3data))
に変更
(Resizeの列数を1からnに変更、Transposeを二重化)

で行けると思います。

補足

ご回答ありがとうございます。

列AN(n=40)までコピーしたかったので、下記の通り編集しましたが

Sh3data(UBound(Sh3data)) = Sh1data(i, 1).EntireRow

この箇所にて「オブジェクトが必要です」
とエラーが出てしまいます。
よろしければアドバイス頂ければ幸いです
----------------------------
Sub TestX()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim Sh3 As Worksheet, Sh4 As Worksheet
Dim Sh5 As Worksheet, Sh6 As Worksheet
Dim Sh1data As Variant, Sh2data As Variant
Dim Sh3data As Variant, Sh4data As Variant
Dim Sh5data As Variant, Sh6data As Variant
Dim Sh1LastRow As Long, Sh2LastRow As Long
Dim i As Long, j As Long, Sh5flg As Boolean

Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
Set Sh3 = Worksheets("Sheet3")
Set Sh4 = Worksheets("Sheet4")
Set Sh5 = Worksheets("Sheet5")
Set Sh6 = Worksheets("Sheet6")

ReDim Sh3data(0)
ReDim Sh4data(0)
ReDim Sh5data(0)
ReDim Sh6data(0)

Sh1LastRow = Sh1.Cells(Rows.Count, "A").End(xlUp).Row
Sh2LastRow = Sh2.Cells(Rows.Count, "A").End(xlUp).Row

Sh1data = Sh1.Range(Sh1.Cells(3, "A"), Sh1.Cells(Sh1LastRow, "B")).Value
Sh2data = Sh2.Range(Sh2.Cells(3, "A"), Sh2.Cells(Sh2LastRow, "B")).Value

For i = 1 To Sh1LastRow - 2
Sh5flg = False
For j = 1 To Sh2LastRow - 2
If Sh1data(i, 1) = Sh2data(j, 1) Then
If Sh2data(j, 2) <> "◯" Then
Sh1data(i, 2) = "◯"
Sh3data(UBound(Sh3data)) = Sh1data(i, 1).EntireRow　'編集箇所
ReDim Preserve Sh3data(UBound(Sh3data) + 1)
Sh2data(j, 2) = "◯"
Else
Sh5data(UBound(Sh5data)) = Sh1data(i, 1).EntireRow　'編集箇所
ReDim Preserve Sh5data(UBound(Sh5data) + 1)
Sh5flg = True
End If
Exit For
End If
Next j
If Sh1data(i, 2) <> "◯" And Sh5flg = False Then
Sh5data(UBound(Sh5data)) = Sh1data(i, 1).EntireRow　'編集箇所
ReDim Preserve Sh5data(UBound(Sh5data) + 1)
End If
Next i
For i = 1 To Sh2LastRow - 2
If Sh2data(i, 2) = "◯" Then
Sh4data(UBound(Sh4data)) = Sh2data(i, 1).EntireRow　'編集箇所
ReDim Preserve Sh4data(UBound(Sh4data) + 1)
Else
Sh6data(UBound(Sh6data)) = Sh2data(i, 1).EntireRow　'編集箇所
ReDim Preserve Sh6data(UBound(Sh6data) + 1)
End If
Next
Sh1.Range("A3").Resize(Sh1LastRow - 2, 2).Value = Sh1data
Sh2.Range("A3").Resize(Sh2LastRow - 2, 2).Value = Sh2data
Sh3.Range("A3").Resize(UBound(Sh3data), 40).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Sh3data))　'編集箇所
Sh4.Range("A3").Resize(UBound(Sh4data), 40).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Sh4data))　'編集箇所
Sh5.Range("A3").Resize(UBound(Sh5data), 40).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Sh5data))　'編集箇所
Sh6.Range("A3").Resize(UBound(Sh6data), 40).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Sh6data))　'編集箇所

Set Sh1 = Nothing
Set Sh2 = Nothing
Set Sh3 = Nothing
Set Sh4 = Nothing
Set Sh5 = Nothing
Set Sh6 = Nothing
End Sub