Macro: Move active row to top of VISIBLE rows?

[jeffcoleky]

Rows 2-XXXXX are all hidden. The row number of the last hidden row increases occasionally.

I need a macro that will move the row of currently active cell, to the top of the VISIBLE (unhidden) rows.

For instance, if rows 2-1500 are hidden and the cursor is on cell D1600, when the macro is run it would CUT row 1600 and paste it (insert cut cells) between as 1501.

Can anyone please help?

 

[jeffcoleky]

what info can I add to motivate someone to come to my rescue?

 

[jeffcoleky]

A macro to Paste the selected row to the top of all visible rows...Anyone?

 

[Teeroy]

Try the following. It's based on Column D having values in every row.

Sub MoveRowtoTopOfVisibleRange()
ActiveCell.EntireRow.Cut
With Range("D" & Rows.Count).End(xlUp).CurrentRegion.SpecialCells(xlCellTypeVisible)
    For i = 1 To .Areas.Count
        If Not Intersect(.Areas(i), Cells(ActiveCell.Row, 4)) Is Nothing Then
            intersectArea = i
        End If
    Next i
    .Areas(intersectArea).Cells(1, 1).EntireRow.Insert
End With
End Sub

 

[jeffcoleky]

Try the following. It's based on Column D having values in every row.

Sub MoveRowtoTopOfVisibleRange()
ActiveCell.EntireRow.Cut
With Range("D" & Rows.Count).End(xlUp).CurrentRegion.SpecialCells(xlCellTypeVisible)
    For i = 1 To .Areas.Count
        If Not Intersect(.Areas(i), Cells(ActiveCell.Row, 4)) Is Nothing Then
            intersectArea = i
        End If
    Next i
    .Areas(intersectArea).Cells(1, 1).EntireRow.Insert
End With
End Sub

Works fantastically, just as I requested. However, I mistakenly stated I wanted it to work on one row at a time. Would you be able to easily modify this so that it works on multiple selected rows?

 

[Teeroy]

A few more checks are required. Try the following:

Sub MoveRowtoTopOfVisibleRange2()
Dim rTest As Range
'check for valid selection
Set rTest = Range("D" & Selection.Cells(1, 1).Row & ":D" & Selection.Cells(Selection.Rows.Count, 1).Row)
If rTest.Count > 1 Then
    If rTest.Count <> rTest.SpecialCells(xlCellTypeVisible).Count Then
        MsgBox "That selection is invalid as it crosses hidden rows."
        Exit Sub
    End If
End If
Selection.EntireRow.Cut
With Range("D" & Rows.Count).End(xlUp).CurrentRegion.SpecialCells(xlCellTypeVisible)
    For i = 1 To .Areas.Count
        If Not Intersect(.Areas(i), rTest) Is Nothing Then
            intersectArea = i
        End If
    Next i
    .Areas(intersectArea).Cells(1, 1).EntireRow.Insert
End With
End Sub

 

[jeffcoleky]

Perfect again! thanks so much!