Do not copy range if criteria is not met in advanced filter

[Harshil Mehta]

I have 4 sheets in total in another workbook. I want my code to copy range if the criteria is met in sheet1 of another workbook and if not, then don't copy and move to sheet2, 3 & 4 (if criteria not met don't copy and move to next sheet for all the sheets) and paste data in this workbook sheets(Temp.Sheet). Range.A7 (Headers) one below the other.

The below code seems to copy the entire sheet when the criteria is not met and overwrites the data in the destination.

Could someone please help me figure this out?

Sub Import_Data1()

Dim FileToOpen As Variant
Dim OpenBook As Workbook
Dim lcol, lrow, lrc As Long
Dim ws As Worksheet

Application.ScreenUpdating = False

For Each ws In Worksheets
    ws.Calculate
Next ws


FileToOpen = Application.GetOpenFilename(Title:="Browse for your file & import range", Filefilter:="Excel Files(.xls),xls")
If FileToOpen <> False Then


ThisWorkbook.Worksheets(10).Range(Cells(1, 9), Cells(Rows.Count, Columns.Count)).EntireColumn.Delete

lrc = ThisWorkbook.Worksheets(10).Range("C:C").SpecialCells(xlCellTypeLastCell).Row

ThisWorkbook.Worksheets("Temp.Sheet").Cells.Clear


Set OpenBook = Application.Workbooks.Open(FileToOpen)

With OpenBook.Worksheets(1)


            lcol = .Cells(7, .Columns.Count).End(xlToLeft).Column

            lrow = .Cells(Rows.Count, 1).End(xlUp).Row

            .Range(.Cells(7, 1), .Cells(lrow, lcol)).AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=ThisWorkbook.Worksheets(10).Range("C25:G" & lrc), Copytorange:=ThisWorkbook.Worksheets("Temp.Sheet").Range("A7"), Unique:=False

End With

With OpenBook.Worksheets(2)


            lr = ThisWorkbook.Worksheets("Temp.Sheet").Cells(Rows.Count, 1).End(xlUp).Row

            lcol = .Cells(7, .Columns.Count).End(xlToLeft).Column

            lrow = .Cells(Rows.Count, 1).End(xlUp).Row

            .Range(.Cells(7, 1), .Cells(lrow, lcol)).AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=ThisWorkbook.Worksheets(10).Range("C25:G" & lrc), Copytorange:=ThisWorkbook.Worksheets("Temp.Sheet").Range("A7" & lr + 1), Unique:=False

End With


With OpenBook.Worksheets(3)


            lr = ThisWorkbook.Worksheets("Temp.Sheet").Cells(Rows.Count, 1).End(xlUp).Row

            lcol = .Cells(7, .Columns.Count).End(xlToLeft).Column

            lrow = .Cells(Rows.Count, 1).End(xlUp).Row

            .Range(.Cells(7, 1), .Cells(lrow, lcol)).AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=ThisWorkbook.Worksheets(10).Range("C25:G" & lrc), Copytorange:=ThisWorkbook.Worksheets("Temp.Sheet").Range("A7" & lr + 1), Unique:=False

End With



With OpenBook.Worksheets(4)


            lr = ThisWorkbook.Worksheets("Temp.Sheet").Cells(Rows.Count, 1).End(xlUp).Row

            lcol = .Cells(7, .Columns.Count).End(xlToLeft).Column

            lrow = .Cells(Rows.Count, 1).End(xlUp).Row

            .Range(.Cells(7, 1), .Cells(lrow, lcol)).AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=ThisWorkbook.Worksheets(10).Range("C25:G" & lrc), Copytorange:=ThisWorkbook.Worksheets("Temp.Sheet").Range("A7" & lr + 1), Unique:=False

End With


OpenBook.Close False

Else

Exit Sub

End If


If WorksheetFunction.CountA(Sheets("Temp.Sheet").Range("A8:XFD18")) = 0 Then

    Sheet10.Range(Cells(1, 9), Cells(Rows.Count, Columns.Count)).EntireColumn.Delete
    MsgBox ("No data found as per the criteria.")
    Exit Sub

End If

End Sub

 

[Harshil Mehta]

Do not copy range if criteria is not met in advanced filter

I have 4 sheets in total in another workbook. I want my code to copy range if the criteria is met in sheet1 of another workbook and if not, then don't copy and move to sheet2, 3 & 4 (if criteri...

stackoverflow.com