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

Question

In Excel I'm looking for a VBA macro to do the following:
Search "Sheet2" range A2:Q3500 for any cells containing data (not empty), and copy only those cells.
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

Answer 2

The code below should help you.
Sub CopyNonEmptyData()
Dim intSheet3Row As Integer
intSheet3Row = 2
For Each c In Range("A2:Q3500")
If c.Value <> "" Then
Sheets("Sheet3").Range("A" & intSheet3Row).Value = c.Value
intSheet3Row = intSheet3Row + 1
End If
Next c
End Sub