Home > Enterprise >  How to not copy the filtered data if it's empty or there is no data found?
How to not copy the filtered data if it's empty or there is no data found?

Time:11-10

I am beginner in VBA. How can I ignore if the condition or the filtered table is empty then continue with other condition?

Here is the code I currently use:

   Sub Macro7()
    '
    ' Macro7 Macro
    '
     Dim LastRow As Long
    '
    Sheets("Ref2").Select
    ActiveSheet.Range("$A$1:$O$168").AutoFilter Field:=3, Criteria1:=Sheets("NOV 2022").Range("E1").Value
   ActiveSheet.Range("$A$1:$O$168").AutoFilter Field:=4, Criteria1:=Sheets("NOV 2022").Range("A6").Value
   LastRow = Range("E" & Rows.Count).End(xlUp).Row
   Range("E2:O" & LastRow).SpecialCells(xlCellTypeVisible).Select
   Selection.copy
   Sheets("NOV 2022").Select
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
   ActiveWindow.SmallScroll Down:=21
   Sheets("Ref2").Select
   ActiveSheet.Range("$A$1:$O$168").AutoFilter Field:=4, Criteria1:=Sheets("NOV 2022").Range("A37").Value
   LastRow = Range("E" & Rows.Count).End(xlUp).Row
   Range("E2:O" & LastRow).SpecialCells(xlCellTypeVisible).Select
   Selection.copy
   Sheets("NOV 2022").Select
   Range("C37").Select
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
   ActiveWindow.SmallScroll Down:=21
   Range("C58").Select
   Sheets("Ref2").Select
   ActiveSheet.Range("$A$1:$O$168").AutoFilter Field:=4, Criteria1:=Sheets("NOV 2022").Range("A58").Value
    LastRow = Range("E" & Rows.Count).End(xlUp).Row
    Range("E2:O" & LastRow).SpecialCells(xlCellTypeVisible).Select
   Selection.copy
   Sheets("NOV 2022").Select
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
   ActiveWindow.SmallScroll Down:=27
   Range("C93").Select
   Sheets("Ref2").Select
   ActiveSheet.Range("$A$1:$O$168").AutoFilter Field:=4, Criteria1:=Sheets("NOV 2022").Range("A93").Value
   LastRow = Range("E" & Rows.Count).End(xlUp).Row
   Range("E2:O" & LastRow).SpecialCells(xlCellTypeVisible).Select
   Selection.copy
   Sheets("NOV 2022").Select
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
  End Sub

CodePudding user response:

Copy Filtered Data (Translating Macro-Recorder Code)

Option Explicit

Sub UpdateNov2022()
    
    Dim CriteriaAddresses() As Variant:
    CriteriaAddresses = VBA.Array("E1", "A6", "A37", "A58", "A93")
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets("Ref2")
    If sws.FilterMode Then sws.ShowAllData
    
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion ' Table Range
    
    Dim scrg As Range ' Copy Range (no headers)
    With srg
        Set scrg = srg.Columns("E:O").Resize(.Rows.Count - 1).Offset(1)
    End With
    
    Dim dws As Worksheet: Set dws = wb.Worksheets("NOV 2022")
    
    Dim dcCell As Range ' Criteria Cell
    Dim CriteriaString As String
    
    Set dcCell = dws.Range(CriteriaAddresses(0))
    CriteriaString = CStr(dcCell.Value)
    srg.AutoFilter Field:=3, Criteria1:=CriteriaString
    
    Dim svrg As Range ' Visible Range (no headers)
    Dim dpCell As Range ' Paste Cell
    Dim n As Long
    
    For n = 1 To UBound(CriteriaAddresses)
        Set dcCell = dws.Range(CriteriaAddresses(n))
        CriteriaString = CStr(dcCell.Value)
        srg.AutoFilter Field:=4, Criteria1:=CriteriaString
        On Error Resume Next
            Set svrg = scrg.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not svrg Is Nothing Then
            svrg.Copy
            Set dpCell = dws.Cells(dcCell.Row, "C")
            dpCell.PasteSpecial Paste:=xlPasteValues
            Set svrg = Nothing
        End If
    Next n
      
    Application.CutCopyMode = False
    sws.ShowAllData ' or to remove: sws.AutoFilterMode = False 
  
End Sub
  • Related