Copy only non blank filtered cells

[ysherriff]

Hi

I am consolidating various workbooks into one master workbook and some workbooks that I am consolidating have no data in the copy range. How can I modify the below code to skip or copy non blank cells.

Thanks for your help.

 Set sh = Sheets("Hospitalized Patient")
  'activate hospital patient sheet
  Sheets("Hospitalized Patient").Activate
  With ActiveSheet
  .Unprotect "ops"
  .AutoFilterMode = False
  .Columns("B:l").EntireColumn.Hidden = False
  .Range("b4:l225").AutoFilter
  .Range("b4:l225").AutoFilter field:=1, Criteria1:="<>", Operator:=xlOr, Criteria1:="<>end"
  End With
 
  'copy filtered data
  Set tbl = ActiveSheet.AutoFilter.Range
  tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Select
  Selection.Copy
 
  'activate lead workbook
  wkbkLead.Activate
 
 
  'activate master worksheet
  TargetShHosp.Activate
 
  TargetShHosp.Range(DestCellHosp.Address).Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False
  Set DestCellHosp = TargetSh.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)

 

[Luke M]

Assuming that:
Data in the table is all contstants, not formulas
It's an entire row that will be blank

Change the one section to this:

Dim rngNew As Range

'copy filtered data
Set tbl = ActiveSheet.AutoFilter.Range
On Error Resume Next
Set rngNew = tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1) _
    .SpecialCells(xlCellTypeConstants).Copy
On Error GoTo 0

'Test if any data found
If rngNew Is Nothing Then
    'Skip this block
    Exit Sub
Else
    rngNew.Copy
End If

'Continue on with rest of code...

 

[Stevie]

mm I don't know a way to only copy the cells with values, but you could do this instead:
Change your code section to:

    Set sh = Sheets("Hospitalized Patient")
    'activate hospital patient sheet
    Sheets("Hospitalized Patient").Activate
    With ActiveSheet
        .Unprotect "ops"
        .AutoFilterMode = False
        .Columns("B:l").EntireColumn.Hidden = False
        .Range("b4:l225").AutoFilter
        .Range("b4:l225").AutoFilter field:=1, Criteria1:="<>", Operator:=xlOr, Criteria1:="<>end"
    End With
  
    'copy filtered data
    Set tbl = ActiveSheet.AutoFilter.Range
    Set tbl = tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Select
    For Each cell In tbl.Cells
        If cell <> "" Then
            wkbklead.TargetShHosp.Range(DestCellHosp.Address).Offset(cell.Row - tbl.Row, cell.Column - tbl.Column) = cell.Value
        End If
    Next
    TargetShHosp.Activate
    Set DestCellHosp = TargetSh.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)

I am running through each cell in the copy range and where the cell is not blank, setting the appropriate cell in the paste range to the same value.

If this was useful, please click like!


Edit: I seem to have a different understanding to Luke, I am assuming that it is oddly shaped blank sections of ranges (such as the layout of a workbook) which are causing problems, so I am 'ignoring' them.
Luke is assuming that sometimes your whole range is blank, and skipping the range in its entirety. Whichever is the case, one of our posts should be an adequate solution, Luke's being the more efficient if his assumptions are correct.