VBA Paste on filtered sheet

Question

I want to paste copied cells into only visible cells inside a sheet where the filter is active using VBA

Thinking it would be a simple task I initially create a sub like this:

Public Sub PasteFlt()
    Selection.SpecialCells(xlCellTypeVisible).PasteSpecial xlPasteValues
End Sub

but it doesn't work at all

After a lot of tries and debugging I finally made it work using this code:

Public Sub PasteFlt()

    On Error Resume Next

    Dim rDest As Range, rSrc As Range
    Dim tCell As Range
    Dim r As Integer, tR As Integer
    Dim c As Integer

    Application.ScreenUpdating = False
    Set rDest = Selection
    Worksheets.Add
    ActiveSheet.Paste
    Set rSrc = Selection

    r = 0
    tR = 0
    For Each tCell In rDest.SpecialCells(xlCellTypeVisible)
        If (tCell.row - rDest.row + 1) > tR Then
            r = r + 1
            tR = tCell.row - rDest.row + 1
        End If
        c = tCell.Column - rDest.Column + 1
        If r <= rSrc.Rows.Count Then
            If c <= rSrc.Columns.Count Then
                tCell.Value = rSrc(r, c)
            End If
        Else
            Exit For
        End If
    Next tCell

    Application.DisplayAlerts = False
    ActiveWindow.SelectedSheets.Delete
    Application.DisplayAlerts = True
    
End Sub

It does what I want but I don't really like it. My question is: Is there an easier way on doing so without creating and deleting a new sheet, like my first attempt? Maybe I'm simply missing something there

Answer 1

This is a procedure I wrote in reply to a question posted elsewhere - it may or may not suit your requirement:-

Sub filteredCopyPaste()
    Dim source As Range, destination As Range
    Dim addresses() As String, otherBook As String
    Dim cell As Range, i As Long, width As Integer
    
    Application.DisplayAlerts = False
    On Error Resume Next
    
    Do
        Set source = Application.InputBox("Select the range* to be copied" + vbNewLine _
                                                                + "* include the header(s)", "Source data...", , , , , , 8)
    Loop While source Is Nothing
    
    width = source.Columns.Count
    
tryAgain:
    Do
        Set destination = Application.InputBox("Select the range* to be pasted" + vbNewLine _
                                                                    + "* include the header(s)", "Destination data...", , , , , , 8)
    Loop While destination Is Nothing
    
    If destination.Columns.Count <> width Then
        MsgBox "The area to be pasted must be of the same width" + vbNewLine + _
                        "   as the area from which data are being copied", vbOKOnly + vbExclamation, "Wrong size!"
        GoTo tryAgain
    End If
    
    On Error GoTo 0
    
    Set source = source.Offset(1, 0).Resize(source.Rows.Count - 1, width).SpecialCells(xlCellTypeVisible)
    Set destination = destination.Offset(1, 0).Resize(destination.Rows.Count - 1, width).SpecialCells(xlCellTypeVisible)
    
    If source.Cells.Count <> destination.Cells.Count Then
        MsgBox "The number of filtered cells in the source range differs from" + vbNewLine + _
                        "       the number of filtered cells in the destination range.", vbOKOnly + vbCritical, "Unequal ranges selected!"
        Exit Sub
    End If
        
    ReDim addresses(1 To source.Rows.Count)
 
    If source.Parent.Parent.Name <> destination.Parent.Parent.Name Then
        otherBook = "'[" & source.Parent.Parent.Name & "]"
    Else
        otherBook = "'"
    End If
    
    i = 1
    For Each cell In source.Rows
        addresses(i) = otherBook & cell.Parent.Name & "'!" & cell.Address
        i = i + 1
    Next cell
    
    i = 1
    For Each cell In destination.Rows
        Range(addresses(i)).Copy cell
        i = i + 1
    Next cell
End Sub

Answer 2

This procedure proposed by @Spectral Instance can be shortened a bit, but it is important whether both the source and destination ranges are non-continuous or only the target. I give two proposals suitable for each of these cases.

Sub filteredCopyPaste2()
    ' single loop, source range is continuous
    Dim source As Range, destination As Range
    Dim cell As Range, i As Long, width As Integer
    
    On Error Resume Next
    
    Set source = Application.InputBox("Select the range* to be copied" + vbNewLine _
               & "* include the header(s)", "Source data...", , , , , , 8)
    If source Is Nothing Then Exit Sub
    width = source.Columns.Count
    
tryAgain:
    Set destination = Application.InputBox("Select the range* to be pasted" & vbNewLine _
             & "* include the header(s)", "Destination data...", , , , , , 8)
    If destination Is Nothing Then Exit Sub
    
    If destination.Columns.Count <> width Then
        MsgBox "The area to be pasted must be of the same width" & vbNewLine & _
               "   as the area from which data are being copied", vbOKOnly + vbExclamation, "Wrong size!"
        GoTo tryAgain
    End If
    
    On Error GoTo 0
    
    Set source = source.Offset(1, 0).Resize(source.Rows.Count - 1, width) '  continuous range
    Set destination = destination.Offset(1, 0).Resize(destination.Rows.Count - 1, width).SpecialCells(xlCellTypeVisible)
    
    If source.Cells.Count <> destination.Cells.Count Then
        MsgBox "The number of filtered cells in the source range differs from" & vbNewLine & _
               "       the number of filtered cells in the destination range.", vbOKOnly + vbCritical, "Unequal ranges selected!"
        Exit Sub
    End If
 
    i = 1
    ' it is strange, however it works
    For Each cell In destination.Rows
        cell.Value = source.Rows(i).Value
        i = i + 1
    Next cell
End Sub

Sub filteredCopyPaste3()   ' two loops, both ranges filtered
    Dim source As Range, destination As Range
    Dim addresses() As String
    Dim cell As Range, i As Long, width As Integer
    
    On Error Resume Next
    
    Set source = Application.InputBox("Select the range* to be copied" + vbNewLine _
                                & "* include the header(s)", "Source data...", , , , , , 8)
    If source Is Nothing Then Exit Sub
    width = source.Columns.Count
    
tryAgain:
    Set destination = Application.InputBox("Select the range* to be pasted" & vbNewLine _
              & "* include the header(s)", "Destination data...", , , , , , 8)
    If destination Is Nothing Then Exit Sub
    
    If destination.Columns.Count <> width Then
        MsgBox "The area to be pasted must be of the same width" & vbNewLine & _
               "   as the area from which data are being copied", vbOKOnly + vbExclamation, "Wrong size!"
        GoTo tryAgain
    End If
    
    On Error GoTo 0
    
    Set source = source.Offset(1, 0).Resize(source.Rows.Count - 1, width).SpecialCells(xlCellTypeVisible)
    Set destination = destination.Offset(1, 0).Resize(destination.Rows.Count - 1, width).SpecialCells(xlCellTypeVisible)
    
    If source.Cells.Count <> destination.Cells.Count Then
        MsgBox "The number of filtered cells in the source range differs from" & vbNewLine & _
               "       the number of filtered cells in the destination range.", vbOKOnly + vbCritical, "Unequal ranges selected!"
        Exit Sub
    End If
        
    ReDim addresses(1 To source.Count / width)   ' total rows count
 
    i = 1
    ' it is strange, however it works
    For Each cell In source.Rows
        addresses(i) = cell.Address(External:=True)
        i = i + 1
    Next cell
    
    i = 1
    For Each cell In destination.Rows
        Range(addresses(i)).Copy cell
        i = i + 1
    Next cell
End Sub