Sub Reorganiser()
Dim t, i&, n1&, n2&
Application.ScreenUpdating = False
t = Range("a1").CurrentRegion: n2 = [f1].Column
For i = UBound(t) To 2 Step -1
n1 = Application.Match(t(i, 2), Range("f1").Resize(, UBound(t)), 0) + [f1].Column - 1
If n1 <> n2 Then Columns(n1).Cut: Columns(n2).Insert
Next i
End Sub