复制活动行并在下面插入，即使使用活动过滤器

Question

已成功编写代码以插入活动行的 1,3 或 5 行副本 - 在活动行下方。 但是，当过滤器打开时它不起作用。

我有一张纸 周，员工编号，数据 - 按员工编号排序。 筛选出一名员工。

现在，我想复制我正在标记的行并在下面插入 x 行 - 并“留在活动行上” - 即使我必须做任何体操来删除和添加过滤器......我希望和相信还有另一种方法。

我找到了“SpecialCells(xlCellTypeVisible)”，但似乎无法正确放置它 - 它在我的工作表顶部插入了 5 行 :-)

希望有人能帮忙...我的代码是这样的

Sub Insert5Rows()

Dim xcount As Integer
xcount = 5

    ActiveCell.EntireRow.Copy
    Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(xcount, 0)).EntireRow.Insert Shift:=xlDown
    Application.CutCopyMode = False
     
End Sub

先谢谢了！！！

Answer 1

激活时插入复制的行自动筛选

• 我认为不移除过滤器是不可能的（肯定不可靠）。
• 过程getFilterData 和restoreFilters 将分别删除和重新应用过滤器。
• 它肯定没有经过足够的测试，所以要小心。欢迎提供任何反馈。

守则

Option Explicit

Sub insertData()
    
    Const CopiesCount As Long = 5
    
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    Dim ws As Worksheet: Set ws = Selection.Worksheet
    Dim cel As Range: Set cel = Selection.Cells(1)
    Dim rg As Range: Set rg = cel.CurrentRegion
    
    Dim FilterData As Variant
    Dim avoidFilter As Boolean
    If ws.AutoFilterMode Then
        FilterData = getFilterData(rg)
        ws.AutoFilterMode = False
        avoidFilter = True
    End If
    
    With rg.Rows(cel.Row - rg.Row + 1)
        .Copy
        With .Offset(1).Resize(CopiesCount)
            .Insert xlShiftDown
        End With
    End With
    
    If avoidFilter Then
        restoreFilters rg, FilterData
    Else
        Application.CutCopyMode = False
    End If

End Sub

Function getFilterData( _
    ByVal rg As Range) _
As Variant
    With rg.Worksheet.AutoFilter
        With .Filters
            Dim FilterData As Variant: ReDim FilterData(1 To .Count, 1 To 3)
            Dim n As Long
            For n = 1 To .Count
                With .Item(n)
                    If .On Then
                        FilterData(n, 1) = .Criteria1
                        If .Operator Then
                            FilterData(n, 2) = .Operator
                            On Error Resume Next ' Not investigated errors.
                            FilterData(n, 3) = .Criteria2
                            On Error GoTo 0
                        End If
                    End If
                End With
            Next n
        End With
    End With
    getFilterData = FilterData
End Function

Sub restoreFilters( _
        ByRef rg As Range, _
        ByVal BackupData As Variant)
    Dim n As Long
    For n = 1 To UBound(BackupData, 1)
        If Not IsEmpty(BackupData(n, 1)) Then
            If BackupData(n, 2) Then
                rg.AutoFilter Field:=n, Criteria1:=BackupData(n, 1), _
                    Operator:=BackupData(n, 2), Criteria2:=BackupData(n, 3)
            Else
                rg.AutoFilter Field:=n, Criteria1:=BackupData(n, 1)
            End If
        End If
    Next n
End Sub