Maybe:
Sub alexxgalaxy()
Dim lr As Long
Dim rcell As Range
Dim i As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr
Range(Range("A" & i), Range("G" & i)).Copy
Range("I" & Rows.Count).End(3)(2).PasteSpecial Transpose:=True
Next i
lr = Cells(Rows.Count, 9).End(xlUp).Row
For Each rcell In Range("I2:I" & lr)
If Left(rcell, 4) = "Team" Then
rcell.Cut rcell.Offset(, -1)
End If
Next rcell
Range("I2").Delete xlUp
For Each rcell In Range("H2:H" & lr)
If rcell.Offset(, 1) <> "" Then
rcell.Offset(1, 1).Select
Do Until ActiveCell = ""
ActiveCell.Offset(, -1).Value = rcell.Value
ActiveCell.Offset(1).Select
Loop
End If
Next rcell
Range("H1:I" & lr).SpecialCells(xlCellTypeBlanks).Delete xlUp
Columns("A:G").Delete xlToLeft
Application.ScreenUpdating = True
End Sub
Bookmarks