copy active row and insert below even with active filter

1
votes

Have succeeded to make code to insert 1,3 or 5 rows of copies of the active row - below the active row. However it does not work when the filter is on.

I have a sheet with Week, Employee number, data - sorted by employee number. Filtered on one employee.

Now, I would like to copy the row I am marking and insert x number of rows below - and "stay on the activerow" - even though I have to do whatever gymnastics to remove and add filter... I hope and trust there is another way.

I have found the "SpecialCells(xlCellTypeVisible)" but cannot seem to place it coorectly - it inserted 5 rows in the top of my sheet :-)

I hope someone can help... My code looks like this

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

Thanks a bunch in advance!!!

1
excelvbafilterinsert

1 Answers

2
votes

Insert Copied Rows When Active AutoFilter

  • I don't think it is possible (surely not reliable) without removing the filter.
  • The procedures getFilterData and restoreFilters will remove and reapply respectively the filters.
  • It surely is not tested enough, so take caution. Any feedback is most welcome.

The Code

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