Search for not empty cells in range, paste to new sheet

Question

In Excel I'm looking for a VBA macro to do the following:

1. Search "Sheet2" range A2:Q3500 for any cells containing data (not empty), and copy only those cells.

2. Paste those cells' exact values into "Sheet3" starting with cell A2.

When I say "exact value" I just mean text/number in the cell is exactly the same as it appeared when copied, no different formatting applied.

Any guidance would be super appreciated, thank you!

Answer 1

Copy Filtered Data

• The following will copy the complete table range and then delete the 'empty' rows.
• Adjust the values in the constants section.

Option Explicit

Sub CopyFilterData()

    ' Source
    Const sName As String = "Sheet2"
    Const sFirst As String = "A1"
    ' Destination
    Const dName As String = "Sheet3"
    Const dFirst As String = "A1"
    Const dfField As Long = 1
    Const dfCriteria As String = "="
    ' Both
    Const Cols As String = "A:Q"
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    If sws.AutoFilterMode Then sws.AutoFilterMode = False
    Dim sfCell As Range: Set sfCell = sws.Range(sFirst)
    
    Dim slCell As Range
    With sfCell.Resize(sws.Rows.Count - sfCell.Row + 1)
        Set slCell = .Find("*", , xlFormulas, , , xlPrevious)
    End With
    If slCell Is Nothing Then Exit Sub ' no data in column range
    
    Dim rCount As Long: rCount = slCell.Row - sfCell.Row + 1
    If rCount = 1 Then Exit Sub ' only headers
    
    Dim scrg As Range: Set scrg = sfCell.Resize(rCount) ' Criteria Column Range
    Dim srg As Range: Set srg = scrg.EntireRow.Columns(Cols) ' Table Range
    Dim cCount As Long: cCount = srg.Columns.Count
    
    Application.ScreenUpdating = False
    
    ' Destination
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    If dws.AutoFilterMode Then dws.AutoFilterMode = False
    dws.UsedRange.Clear
    Dim dfcell As Range: Set dfcell = dws.Range(dFirst)
    Dim drg As Range: Set drg = dfcell.Resize(rCount, cCount) ' Table Range
    
    srg.Copy drg ' copy
    
    Dim ddrg As Range: Set ddrg = drg.Resize(rCount - 1).Offset(1) ' Data Range
    
    drg.AutoFilter dfField, dfCriteria
    
    Dim ddfrg As Range ' Data Filtered Range
    On Error Resume Next
        Set ddfrg = ddrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    dws.AutoFilterMode = False
    
    If Not ddfrg Is Nothing Then
        ddfrg.EntireRow.Delete ' delete 'empty' rows
    End If
    
    'drg.EntireColumn.AutoFit
    'wb.Save
    
    Application.ScreenUpdating = True
    
    MsgBox "Data copied.", vbInformation, "Copy Filtered Data"

End Sub