How to grab multiple rows excluding hidden ones and move them in Excel VBA-CodePudding

I am trying to copy and paste as many rows are selected from one sheet to another and then delete the row after it's moved using loops; but I need to be able to skip hidden rows.

Right now my code is only working for the first row in my selection - it will move it entirely including deleting it and leaving hidden rows hidden. I added the m integer though because before adding it and just using the k integer (and scaling it up by 1 each loop) it would grab more rows than necessary, including any hidden rows. Any advice on how to get this to work for my entire selection would be much appreciated. Thank you!

Dim c As Range
Dim Howmany As Long
Howmany = Selection.Rows.Count
Dim Where As String
Where = ActiveCell.EntireRow.Address
Dim WhatRow As Long
WhatRow = ActiveCell.EntireRow.Row


    Dim j As Integer
    Dim k As Integer
    Dim m As Integer

        k = 0
        m = 0
    j = Range(Where).Offset(k, 0).Row
        For Each c In Selection
            If m <> Howmany   1 Then

                Dim i As Integer
                    i = 2
                    k = 0
                j = Range(Where).Offset(k, 0).Row
                If Cells(j, 1).EntireRow.Hidden = False Then
                    Do While Sheets("Disposition").Range("a" & i).Value <> ""
                        i = i   1
                    Loop
    
                    Range(Cells(j, "a"), Cells(j, "W")).Copy
                    
                    Sheets("Disposition").Rows(i).PasteSpecial
                    Sheets("Disposition").Range("v" & i).Value = Now
    
    
                    ActiveCell.EntireRow.Delete
                End If

                m = m   1
            Else
                MsgBox (Howmany)
                Exit Sub
            End If
        
        Next c


    k = k   1

CodePudding user response：

Cut Visible Rows

Option Explicit

Sub CutVisibleRows()
    
    Const DST_NAME As String = "Disposition"
    
    If ActiveSheet Is Nothing Then Exit Sub ' no visible workbooks open
    If Not TypeOf Selection Is Range Then Exit Sub ' no range selected
    
    Dim srg As Range
    On Error Resume Next
    Set srg = Selection.EntireRow.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If srg Is Nothing Then Exit Sub ' no visible cells
    
    Dim srCount As Long
    srCount = Intersect(srg, srg.Worksheet.Columns("A")).Cells.Count
    
    Dim dws As Worksheet
    On Error Resume Next
        Set dws = srg.Worksheet.Parent.Sheets(DST_NAME)
    On Error GoTo 0
    If dws Is Nothing Then Exit Sub ' destination worksheet not found
    
    If dws.FilterMode Then dws.ShowAllData
    
    Dim dCell As Range: Set dCell = dws.UsedRange _
        .Find("*", , xlFormulas, , xlByRows, xlPrevious)
    If dCell Is Nothing Then
        Set dCell = dws.Range("A1")
    Else
        Set dCell = dws.Cells(dCell.Row   1, "A")
    End If
    
    srg.Copy dCell
    dCell.EntireRow.Columns("V").Resize(srCount).Value = Now
    srg.Delete

    MsgBox srCount & " row" & IIf(srCount = 1, "", "s") & " cut.", vbInformation

End Sub