Move cells to the next column

[Closed]
Report
-
 Helper -
Hello,

I have a report that comes already formated for printing. However, I want to be able to manipulate the data to analyze it. Currently the report has a colums with employee's name and the division they belong to right below their name. I want to create a colum adjecent to their name called division and move their assigned division over. I could do it with a drag and drop but we are talking about several hundred employees. And to complicate things, there are empty cells between one employee and the next, for example:

Name

Joe Smith
yellow team


Mary Sue
blue team

Carol Who
red team

I would like to delete the spaces (empty cells) and move their team name to the next colum over. Can I run a Macro for that?

1 reply

Assumption:
The employee names are in Column A


Private Sub CommandButton1_Click()

Dim i
Dim dup
Dim r
r = Range("A65536").End(xlUp).Row 'This will find the last used row regardless of empty cells
i = 1

Columns("B:B").Select 'You stated creating a column so I assume you want to insert column for the team name
Selection.Insert Shift:=xlToRight

'This will first move the team names beside the person's name and delete the team name.
For i = i To r

If Not IsEmpty(Range("A" & i)) And Right(Range("A" & i), 4) = "team" Then
dup = i

Range("B" & i).Offset(-1, 0) = Range("A" & dup)
Rows(dup).EntireRow.Delete Shift:=xlUp

End If

Next i

i = 1
'Now we can delete the empty rows
Rows(r).Select
For r = r To i Step -1

If Range("A" & r) = "" Then
Rows(r).EntireRow.Delete
End If

Next r

Range("A1").Select

End Sub