如何抓取不包括隐藏行的多行并将它们移动到 Excel VBA

Question

我正在尝试将尽可能多的行从一张纸复制并粘贴到另一张纸上，然后在使用循环移动该行后将其删除； 但我需要能够跳过隐藏的行。

现在我的代码只适用于我选择的第一行——它将完全移动它，包括删除它并隐藏隐藏的行。 我添加了 m integer，因为在添加它之前，仅使用 k integer（并在每个循环中将其放大 1），它会获取比必要更多的行，包括任何隐藏的行。 任何关于如何让它适用于我的整个选择的建议都将不胜感激。 谢谢！

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

Answer 1

切割可见行

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