VBA 粘贴到过滤表上

Question

我想使用 VBA 将复制的单元格粘贴到过滤器处于活动状态的工作表内的可见单元格中

认为这将是一个简单的任务，我最初创建了一个这样的子：

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

但是根本不起作用

经过多次尝试和调试，我终于使用此代码使其工作：

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

它满足了我的要求，但我不太喜欢它。 我的问题是：是否有一种更简单的方法可以做到这一点，而无需创建和删除新工作表，就像我的第一次尝试一样？也许我只是错过了一些东西

Answer 1

这是我在回复其他地方发布的问题时编写的程序 - 它可能适合也可能不适合您的要求：-

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