配列を使用してみました。
ただし、AとBで同じ項番でデータが違う場合は考慮していません。
Option Explicit
Option Base 1
Sub OneCase()
Dim miniNo As Long, maxNo As Long, i As Long, j As Long, a As Long, b As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim dataArrayA, dataArrayB
Dim wsFunc As WorksheetFunction
Const ITEM_COUNT As Integer = 3
Const B_POS As Long = 5
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set wsFunc = WorksheetFunction
With ws1
miniNo = wsFunc.Min(.Range("A:A,E:E"))
maxNo = wsFunc.Max(.Range("A:A,E:E"))
ReDim dataArrayA(maxNo - (miniNo - 1), ITEM_COUNT)
ReDim dataArrayB(maxNo - (miniNo - 1), ITEM_COUNT)
For i = 3 To .Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To ITEM_COUNT
dataArrayA(.Cells(i, 1).Value, j) = .Cells(i, j).Value
Next j
Next i
For i = 3 To .Cells(Rows.Count, "E").End(xlUp).Row
For j = 1 To ITEM_COUNT
dataArrayB(.Cells(i, B_POS).Value, j) = .Cells(i, j + (B_POS - 1)).Value
Next j
Next i
End With
Application.ScreenUpdating = False
ws2.Range("A1:G2").Value = ws1.Range("A1:G2").Value
ws2.Range("A3").Resize(UBound(dataArrayA), UBound(dataArrayA, 2)) = dataArrayA
ws2.Range("E3").Resize(UBound(dataArrayB), UBound(dataArrayB, 2)) = dataArrayB
Application.ScreenUpdating = True
End Sub
