Public Sub Reformat()
Dim wsLook As Worksheet
Dim cellFind As Range
Dim firstFound As String
Dim rowLast As Long
Dim rowFirst As Long
Dim rowNext As Long
Dim i As Long
Application.ScreenUpdating = False
Set wsLook = Worksheets("Sheet2")
With Worksheets("Sheet1")
rowLast = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = rowLast To 2 Step -1
If .Cells(i, "B").Value <> "" Then
Set cellFind = Nothing
On Error Resume Next
Set cellFind = wsLook.Columns(1).Find(Cells(i, "B").Value, after:=wsLook.Range("A1"))
On Error GoTo 0
If Not cellFind Is Nothing Then
firstFound = cellFind.Address
rowNext = 0
Do
If rowNext > 0 Then Rows(i + rowNext).Insert
.Cells(i + rowNext, "D").Value = cellFind.Offset(0, 1).Value
.Cells(i + rowNext, "E").Value = cellFind.Offset(0, 2).Value
Set cellFind = wsLook.Columns(1).FindNext(cellFind)
rowNext = rowNext + 1
Loop Until cellFind Is Nothing Or cellFind.Address = firstFound
End If
End If
Next i
End With
Application.ScreenUpdating = True
End Sub