VBA: How to NOT copy if the filtered data is blank?-CodePudding

I have a set of code to advanced filter Dataset's Column F and H if certain criteria are met, after that the filtered data under Column F to I will be copied to another worksheet's next empty row, in sequence (F & G first, then H & I).

With Worksheets("Sheet3")
    .Range("A:K").AutoFilter Field:=6, Criteria:=">=10000000", Operator:=xlAnd, Criteria2:="<=99999999"
    .Range("F2:G" & .Cells(.Rows.Count, "F").End(xlUp).Row).Copy
    Sheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

    .Range("A:K").AutoFilter Field:=8, Criteria:=">=10000000", Operator:=xlAnd, Criteria2:="<=99999999"
    .Range("H2:I" & .Cells(.Rows.Count, "H").End(xlUp).Row).Copy
    Sheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End With

*Note: There are headers in first row of this Dataset.

This code works flawlessly when they are values after filtering. When there isn't any values after filtering, VBA does not stop copying, instead it copies the header of Column F, G, H and I, which is not what I wanted.

The outcome should be - Nothing (including header) is copied to Sheet 4 if there isn't any values after filtering. How can I achieve this?

CodePudding user response：

Please, replace the code you show:

With Worksheets("Sheet3")
    .Range("A:K").AutoFilter Field:=6, Criteria:=">=10000000", Operator:=xlAnd, Criteria2:="<=99999999"
    .Range("F2:G" & .Cells(.Rows.Count, "F").End(xlUp).Row).Copy
    Sheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

    .Range("A:K").AutoFilter Field:=8, Criteria:=">=10000000", Operator:=xlAnd, Criteria2:="<=99999999"
    .Range("H2:I" & .Cells(.Rows.Count, "H").End(xlUp).Row).Copy
    Sheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End With

with this one, which checks if there are visible cells in the range to be copied (except the header):

  Dim rngFG As Range, rngHI As Range, lastRow As Long
  With Worksheets("Sheet3")
    .Range("A:K").AutoFilter field:=6, Criteria:=">=10000000", Operator:=xlAnd, Criteria2:="<=99999999"
    lastRow = .cells(.rows.count, "F").End(xlUp).row
    On Error Resume Next
     Set rngFG = .Range("F2:G" & lastRow).Resize(lastRow - 1).Offset(1).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not rngFG Is Nothing Then 'the range is nothing if no visible cell in it
        .Range("F2:G" & lastRow).Copy
        Sheets("Sheet4").cells(rows.count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    End If
 
    .Range("A:K").AutoFilter field:=8, Criteria:=">=10000000", Operator:=xlAnd, Criteria2:="<=99999999"
    astRow = .cells(.rows.count, "H").End(xlUp).row
    On Error Resume Next
     Set rngHI = .Range("H2:I" & astRow).Resize(lastRow - 1).Offset(1).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not rngFG Is Nothing Then
        .Range("H2:I" & lastRow).Copy
        Sheets("Sheet4").cells(rows.count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    End If
 End With

It assumes that the header (to be excepted in checking) is on the second row.

Not tested, but it should work. Except the case of a typo somewhere in the code, I think. That's why please, send some feedback after testing it. If something does not work as you need, do not hesitate to explain what and in which circumstances...