VBA for Rotating Names while skipping Empty Cells

[joespapi]

Hi all. I'm new to the site. Thanks in advance for the help. I am trying to perfect my rotation macro that moves names up a column while taking the top name and placing it at the bottom but i need it to skip the empty cells in the middle of the column. If new names get added they go in the middle of the rotation and not at the end.

---

[TABLE="class: grid, width: 500, align: center"]
<tbody>[TR]
[TD]My data[/TD]
[TD]what my macro does[/TD]
[TD]what i need it to do[/TD]
[/TR]
[TR]
[TD]joe[/TD]
[TD]jim[/TD]
[TD]jim[/TD]
[/TR]
[TR]
[TD]jim[/TD]
[TD]bob[/TD]
[TD]bob[/TD]
[/TR]
[TR]
[TD]bob[/TD]
[TD][/TD]
[TD]sam[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]sam[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]sam[/TD]
[TD]nick[/TD]
[TD]nick[/TD]
[/TR]
[TR]
[TD]nick[/TD]
[TD]stan[/TD]
[TD]stan[/TD]
[/TR]
[TR]
[TD]stan[/TD]
[TD]joe[/TD]
[TD]joe[/TD]
[/TR]
</tbody>[/TABLE]

---

Public Sub RotateLoader()
Dim rngRest As Range
Dim vaTemp As Variant
Dim iNumUsedRows As Long
Dim iDemotedRow As Long

ActiveWorkbook.Sheets("Rotation").Activate​

With Columns("B").Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas).Activate​

End With

​

iDemotedRow = ActiveCell.Row​

iNumUsedRows = Range("B:B").Rows.Count - _​

Range(Cells(Range("B:B").Rows.Count, ActiveCell.Column), _​

Cells(Range("B:B").Rows.Count, ActiveCell.Column). _​

End(xlUp)).Rows.Count​

vaTemp = Cells(iDemotedRow, ActiveCell.Column).Value​

Set rngRest = Range(Cells(iDemotedRow + 1, ActiveCell.Column), _​

Cells(iNumUsedRows + 1, ActiveCell.Column))​

rngRest.Copy Cells(iDemotedRow, ActiveCell.Column)​

Cells(iNumUsedRows + 1, ActiveCell.Column).Value = vaTemp​

End Sub

 

[pbornemeier]

Try this:

Sub RotateTopToBottomSkipBlanks()
    
    Const lTopDataRow As Long = 2
    Dim lLastRow As Long
    Dim lFirstGroupLastRow As Long
    Dim lSecondGroupFirstRow As Long
    Dim lIndex As Long
    
    lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    lFirstGroupLastRow = Cells(1, 1).End(xlDown).Row
    lSecondGroupFirstRow = Cells(lLastRow, 1).End(xlUp).Row
    
    Cells(lLastRow + 1, 1).Value = Cells(2, 1).Value
    For lIndex = 2 To lLastRow + 1
        Select Case lIndex
        Case Is < lFirstGroupLastRow
            Cells(lIndex, 1).Value = Cells(lIndex + 1, 1).Value
        Case Is = lFirstGroupLastRow
            Cells(lFirstGroupLastRow, 1).Value = Cells(lSecondGroupFirstRow, 1).Value
        Case Is >= lSecondGroupFirstRow
            Cells(lIndex, 1).Value = Cells(lIndex + 1, 1).Value
        End Select
    Next
    Cells(lLastRow + 1, 1).Value = vbNullString
End Sub

 

[pbornemeier]

Slightly more compact:

Option Explicit

Sub RotateTopToBottomSkipBlanks()
    
    Const lTopDataRow As Long = 2
    Dim lLastRow As Long
    Dim lFirstGroupLastRow As Long
    Dim lSecondGroupFirstRow As Long
    Dim lIndex As Long
    
    lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    lFirstGroupLastRow = Cells(1, 1).End(xlDown).Row
    lSecondGroupFirstRow = Cells(lLastRow, 1).End(xlUp).Row
    
    Cells(lLastRow + 1, 1).Value = Cells(2, 1).Value
    For lIndex = 2 To lLastRow + 1
        Select Case lIndex
        Case Is < lFirstGroupLastRow, Is >= lSecondGroupFirstRow
            Cells(lIndex, 1).Value = Cells(lIndex + 1, 1).Value
        Case Is = lFirstGroupLastRow
            Cells(lFirstGroupLastRow, 1).Value = Cells(lSecondGroupFirstRow, 1).Value
        End Select
    Next
    Cells(lLastRow + 1, 1).Value = vbNullString
End Sub

 

[joespapi]

That worked great. I appreciate your assistance. I had worked out a way to get it done but my code ended up being extremely loooooong, this is an excellent upgrade.

-JPF