Insert a Row using VBA when a filter is applied

[Jtm_Preston]

Hello . . . I have a very simple piece of VBA (below) that works perfectly well copying a line and inserting it below itself, as intended. However this doesn't work when a filter is applied. Can anyone kindly suggest a fix?

Sub WLM_Insert_A_New_Line()

ActiveCell.EntireRow.Select
Selection.Copy
ActiveCell.Offset(1).Select
Selection.Insert Shift:=xlDown

End Sub

 

[Jeff2554]

Does the filter need to be there when the insert happens? Or could the filter be removed without messing anything up?
If it's not needed when the insert action happens you could use this code before the insert action.
On Error Resume Next
ThisWorkbook.Sheets("SheetName").ShowAllData
On Error GoTo 0

 

[John_w]

Try this macro. It should work whether or not the sheet is filtered.

Public Sub Insert_New_Row()

    Dim filteredRange As Range
    Dim r1 As Range, r2 As Range
    Dim areaNum As Long
    
    With ActiveSheet
        
        If .FilterMode Then
        
            'Sheet is filtered
            
            'Set range of active cell
            Set r1 = ActiveCell
            
            'Determine filtered area number of active cell
            Set filteredRange = .UsedRange.SpecialCells(xlCellTypeVisible)
            For areaNum = 1 To filteredRange.Areas.Count
                If Not Application.Intersect(r1, filteredRange.Areas(areaNum)) Is Nothing Then
                    Exit For
                End If
            Next
            
            'Determine range of row below active cell. This is either the row below in the same area, or the first row in the next area, or the row below the last area
            
            'Assume it's the row below in same area
            Set r2 = Application.Intersect(r1.Offset(1), filteredRange.Areas(areaNum))
            If r2 Is Nothing Then
                'Not in same area
                If areaNum < filteredRange.Areas.Count Then
                    'First row in next area
                    Set r2 = filteredRange.Areas(areaNum + 1)(1)
                Else
                    'Row below last area
                    Set r2 = filteredRange.Areas(areaNum).Rows(filteredRange.Areas(areaNum).Rows.Count + 1)
                End If
            End If
        
        Else
        
            'Sheet isn't filtered
            
            Set r1 = ActiveCell
            Set r2 = ActiveCell.Offset(1)
            
        End If
        
    End With
    
    'Copy row r1 and insert at r2
    
    r1.EntireRow.Select
    Selection.Copy
    r2.EntireRow.Select
    Selection.Insert Shift:=xlDown
    Application.CutCopyMode = False

End Sub

 

[Jtm_Preston]

Try this macro. It should work whether or not the sheet is filtered.

Public Sub Insert_New_Row()

    Dim filteredRange As Range
    Dim r1 As Range, r2 As Range
    Dim areaNum As Long
   
    With ActiveSheet
       
        If .FilterMode Then
       
            'Sheet is filtered
           
            'Set range of active cell
            Set r1 = ActiveCell
           
            'Determine filtered area number of active cell
            Set filteredRange = .UsedRange.SpecialCells(xlCellTypeVisible)
            For areaNum = 1 To filteredRange.Areas.Count
                If Not Application.Intersect(r1, filteredRange.Areas(areaNum)) Is Nothing Then
                    Exit For
                End If
            Next
           
            'Determine range of row below active cell. This is either the row below in the same area, or the first row in the next area, or the row below the last area
           
            'Assume it's the row below in same area
            Set r2 = Application.Intersect(r1.Offset(1), filteredRange.Areas(areaNum))
            If r2 Is Nothing Then
                'Not in same area
                If areaNum < filteredRange.Areas.Count Then
                    'First row in next area
                    Set r2 = filteredRange.Areas(areaNum + 1)(1)
                Else
                    'Row below last area
                    Set r2 = filteredRange.Areas(areaNum).Rows(filteredRange.Areas(areaNum).Rows.Count + 1)
                End If
            End If
       
        Else
       
            'Sheet isn't filtered
           
            Set r1 = ActiveCell
            Set r2 = ActiveCell.Offset(1)
           
        End If
       
    End With
   
    'Copy row r1 and insert at r2
   
    r1.EntireRow.Select
    Selection.Copy
    r2.EntireRow.Select
    Selection.Insert Shift:=xlDown
    Application.CutCopyMode = False

End Sub

That has done the tick. Thank you very much John_W.

 

[Jtm_Preston]

Try this macro. It should work whether or not the sheet is filtered.

Public Sub Insert_New_Row()

    Dim filteredRange As Range
    Dim r1 As Range, r2 As Range
    Dim areaNum As Long
   
    With ActiveSheet
       
        If .FilterMode Then
       
            'Sheet is filtered
           
            'Set range of active cell
            Set r1 = ActiveCell
           
            'Determine filtered area number of active cell
            Set filteredRange = .UsedRange.SpecialCells(xlCellTypeVisible)
            For areaNum = 1 To filteredRange.Areas.Count
                If Not Application.Intersect(r1, filteredRange.Areas(areaNum)) Is Nothing Then
                    Exit For
                End If
            Next
           
            'Determine range of row below active cell. This is either the row below in the same area, or the first row in the next area, or the row below the last area
           
            'Assume it's the row below in same area
            Set r2 = Application.Intersect(r1.Offset(1), filteredRange.Areas(areaNum))
            If r2 Is Nothing Then
                'Not in same area
                If areaNum < filteredRange.Areas.Count Then
                    'First row in next area
                    Set r2 = filteredRange.Areas(areaNum + 1)(1)
                Else
                    'Row below last area
                    Set r2 = filteredRange.Areas(areaNum).Rows(filteredRange.Areas(areaNum).Rows.Count + 1)
                End If
            End If
       
        Else
       
            'Sheet isn't filtered
           
            Set r1 = ActiveCell
            Set r2 = ActiveCell.Offset(1)
           
        End If
       
    End With
   
    'Copy row r1 and insert at r2
   
    r1.EntireRow.Select
    Selection.Copy
    r2.EntireRow.Select
    Selection.Insert Shift:=xlDown
    Application.CutCopyMode = False

End Sub

Hi John_W,

Thanks again for your suggest. The solution provided worked well in a dummy file I created, however when using it in the live file it doesn't quite work as expected.

My range of filtered data is rows 943 - 964. When stepping through your solution, I can see that the code selects & copies the active row (in this case 964), which is correct, however it then jumps up to row 943 and inserts the row there, rather than inserting it below row 964.

 

[John_w]

I can't reproduce your issue - the macro works ok for me with the filtered data spanning a single area of rows and the active cell in one of those rows, which is what you seem to have. Please post a screenshot of your sheet and also the mini sheet range which includes the row above and below the filtered range using the XL2BB add-in.