行すべての値を張り付けるようにするには
次の突合用マクロですが、照合番号だけでなく行すべてのデータを張り付けたいのですが、どの部分に変更を加えればよいかわかりません。
(添付画像をご覧ください)
・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
お礼
すいません、少し考えれば分かることでした 解決致しました、本当にありがとうございました。
補足
回答ありがとうございます、コード表の参照設定にてチェックが入っていなかったのが原因でした。 (縦の出力はチェックを入れる前でも問題なく出力されました) 助かりました、ありがとうございます。 また、よろしければ教えていただきたいのですが この状態で任意のセルから入れ替えした値を出力するには ReDim buf(tmpFldCnt - 1, tmpRecCnt - 1) buf = adoRs.GetRows Range(Cells(1, 1), Cells(tmpFldCnt, tmpRecCnt)) = buf これをどう変更するとよいのでしょうか? いろいろいじってみたものの、自分の望んだ結果にはなりませんでした。