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

Harshil Mehta

Board Regular
Joined
May 14, 2020
Messages
55
Office Version
  1. 2013
Platform
  1. Windows
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?

VBA Code:
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
 

Some videos you may like

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off

Watch MrExcel Video

Forum statistics

Threads
1,118,775
Messages
5,574,159
Members
412,574
Latest member
shadowfighter666
Top