Problems with pasting while shifting down cells - excel

Question

Hi I am trying to copy info from a workbook into another workbook and paste while shifting cells down.
My problem is that is not pasting the information at all. The code does everything is supposed to except for pasting the rows.
Sub filter_copy_paste()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim whatToFind As String
Dim foundTwo As Range
Dim newSelectionRange As Range
Dim rowSelectionRange As Range
Dim Found_Row As Long
Dim num As Integer
'
Sheets("Sheet1").Select
whatToFind = "Mean"
Set foundTwo = Cells.Find(What:=whatToFind, After:=ActiveCell, LookIn:=xlFormulas2, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'
Found_Row = foundTwo.row
With Sheets("Main").Range("A12:S12").CurrentRegion
.AutoFilter Field:=19, Criteria1:="Yes"
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
'_
' Destination:=Sheets("Sheet1").Range("A1")
'
' I added the following line to insert selection and shift down in Cells above mean
'
Set rowSelectionRange = Rows(Found_Row - 1).Resize(1)
rowSelectionRange.Select
Selection.Insert Shift:=xlDown
End With
'
'Following is added to clean up my previous worksheet
'
Sheets("Main").Select
If ActiveSheet.FilterMode = True Then
ActiveSheet.ShowAllData
End If
Sheets("Main").Select
Rows("3:11").Select
Range("A11").Activate
Selection.EntireRow.Hidden = True
Application.CutCopyMode = False
Sheets("Sheet1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I am expecting the copied rows to be inserted in the range above Mean

Answer 1

This should do what you need:
Sub filter_copy_paste()
Const FIND_THIS As String = "mean" 'use const for fixed values
Dim f As Range, numRows As Long, wsSrc As Worksheet, wsDest As Worksheet
Set wsSrc = ThisWorkbook.Worksheets("Main") 'source table
Set wsDest = ThisWorkbook.Worksheets("Sheet2") 'copy to here
Set f = wsDest.Cells.Find(What:=FIND_THIS, LookIn:=xlFormulas2, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If f Is Nothing Then
MsgBox "'" & FIND_THIS & "' not found on " & wsDest.Name, vbExclamation
Exit Sub
End If
With wsSrc.Range("A12:S12").CurrentRegion
Debug.Print "Data", .Address()
.AutoFilter Field:=19, Criteria1:="Yes"
'how many rows will be copied?
numRows = .Columns(1).SpecialCells(xlCellTypeVisible).Count
f.Resize(numRows).EntireRow.Insert shift:=xlDown 'insert the rows
'copy visible rows
.SpecialCells(xlCellTypeVisible).Copy wsDest.Cells(f.Row - numRows, "A")
End With
wsSrc.ShowAllData
End Sub

Answer 2

Insert Filtered Rows
Sub InsertFilteredRows()
Application.ScreenUpdating = False
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Sheets("Main")
If sws.FilterMode Then sws.ShowAllData
If sws.AutoFilterMode Then sws.AutoFilterMode = False
Dim srg As Range: Set srg = sws.Range("A12").CurrentRegion
srg.AutoFilter Field:=19, Criteria1:="Yes"
Dim svrg As Range: Set svrg = srg.SpecialCells(xlCellTypeVisible)
sws.AutoFilterMode = False
Dim sarg As Range, srCount As Long
For Each sarg In svrg.Areas: srCount = srCount + sarg.Rows.Count: Next sarg
'Debug.Print srg.Address, svrg.Address, srCount
' Destination
Dim dws As Worksheet: Set dws = wb.Sheets("Sheet1")
If dws.FilterMode Then dws.ShowAllData
Dim durg As Range: Set durg = dws.UsedRange
Dim dlCell As Range: Set dlCell = durg.Cells(durg.Cells.CountLarge)
' Starting with the first cell of the used range searching by rows,
' attempt to find the first cell that contains the search string.
' The search is by default case-insensitive ('A=a').
Dim dfCell As Range: Set dfCell = dws.Cells.Find( _
What:="Mean", After:=dlCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows) ' the rest are default parameters
If dfCell Is Nothing Then Exit Sub ' string not found
Dim dirg As Range: Set dirg = Intersect(durg, dfCell.EntireRow) _
.Resize(srCount) ' your code additionally suggests '.Offset(-1)' !?
'Debug.Print svrg.Address, dfCell.Address, dirg.Address
' Insert and copy.
dirg.Insert Shift:=xlShiftDown
' Cannot determine the 'CopyOrigin' parameter without seeing the data.
' Copy.
svrg.Copy dirg.Columns(1).Offset(-srCount)
' Clean up!?
sws.Rows("3:11").Hidden = True
If Not wb Is ActiveWorkbook Then wb.Activate
dws.Select
Application.ScreenUpdating = True
' Inform.
MsgBox "Filtered rows inserted.", vbInformation
End Sub