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!

CodePudding user response：

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

CodePudding user response：

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