如何用VBA向筛选后的可见单元格粘贴内容？求更优方案

最初代码失败的原因 #

你最初写的Selection.SpecialCells(xlCellTypeVisible).PasteSpecial xlPasteValues无法运行，核心问题是筛选后的可见单元格是由多个不连续的区域（Area）组成的，Excel无法直接将复制的连续区域内容映射到这种不连续结构上，尤其是当复制内容的行数、列数与可见区域不匹配时，会直接触发运行时错误。

优化方案（无需新建删除工作表） #

如果完全不想使用临时工作表，可以通过Windows API读取剪贴板文本并解析成数组，再遍历可见单元格赋值。这种方式仅适用于粘贴值（符合你的需求），代码如下：

Option Explicit

' Windows API声明，用于访问剪贴板
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" (ByVal uFormat As Long) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function GlobalSize Lib "kernel32.dll" (ByVal hMem As LongPtr) As Long

Private Const CF_TEXT = 1

Public Sub PasteToFilteredCells_NoTempSheet()
    Dim clipboardText As String
    Dim srcData As Variant
    Dim destRange As Range
    Dim cell As Range
    Dim rowIndex As Long, colIndex As Long
    
    Application.ScreenUpdating = False
    
    ' 读取剪贴板文本数据
    clipboardText = GetClipboardText()
    If clipboardText = "" Then
        MsgBox "剪贴板无有效表格数据！"
        GoTo Cleanup
    End If
    
    ' 将文本解析为二维数组（按制表符、换行符拆分）
    srcData = ParseClipboardTextToArray(clipboardText)
    If IsEmpty(srcData) Then
        MsgBox "无法解析剪贴板数据！"
        GoTo Cleanup
    End If
    
    ' 获取目标可见区域
    On Error Resume Next
    Set destRange = Selection.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If destRange Is Nothing Then
        MsgBox "选中区域无可见单元格！"
        GoTo Cleanup
    End If
    
    rowIndex = 1
    colIndex = 1
    
    ' 遍历可见单元格逐个赋值
    For Each cell In destRange
        If rowIndex <= UBound(srcData, 1) And colIndex <= UBound(srcData, 2) Then
            cell.Value = srcData(rowIndex, colIndex)
        End If
        
        colIndex = colIndex + 1
        If colIndex > UBound(srcData, 2) Then
            colIndex = 1
            rowIndex = rowIndex + 1
            If rowIndex > UBound(srcData, 1) Then Exit For
        End If
    Next cell
    
Cleanup:
    Application.ScreenUpdating = True
End Sub

' 从剪贴板获取纯文本
Private Function GetClipboardText() As String
    Dim hClipMemory As LongPtr
    Dim lpClipMemory As LongPtr
    Dim clipboardData As String
    Dim dataSize As Long
    
    If OpenClipboard(0&) = 0 Then Exit Function
    
    hClipMemory = GetClipboardData(CF_TEXT)
    If hClipMemory = 0 Then
        CloseClipboard
        Exit Function
    End If
    
    lpClipMemory = GlobalLock(hClipMemory)
    If lpClipMemory = 0 Then
        GlobalUnlock hClipMemory
        CloseClipboard
        Exit Function
    End If
    
    dataSize = GlobalSize(hClipMemory)
    clipboardData = Space$(dataSize)
    CopyMemory ByVal clipboardData, ByVal lpClipMemory, dataSize
    
    GlobalUnlock hClipMemory
    CloseClipboard
    
    ' 移除末尾空字符
    GetClipboardText = Left$(clipboardData, InStr(clipboardData, vbNullChar) - 1)
End Function

' 将剪贴板文本转换为二维数组
Private Function ParseClipboardTextToArray(text As String) As Variant
    Dim rows As Variant
    Dim arr() As Variant
    Dim i As Long, j As Long
    Dim cellArr As Variant
    
    rows = Split(text, vbCrLf)
    If UBound(rows) < 0 Then Exit Function
    
    ' 初始化数组维度
    ReDim arr(1 To UBound(rows) + 1, 1 To UBound(Split(rows(0), vbTab)) + 1)
    
    For i = 0 To UBound(rows)
        If rows(i) <> "" Then
            cellArr = Split(rows(i), vbTab)
            For j = 0 To UBound(cellArr)
                arr(i + 1, j + 1) = cellArr(j)
            Next j
        End If
    Next i
    
    ParseClipboardTextToArray = arr
End Function

' 内存复制辅助API
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
    ByVal Destination As String, _
    ByVal Source As LongPtr, _
    ByVal Length As Long)

更简洁高效的方案（临时表极简版） #

如果你可以接受临时工作表的短暂创建（几乎无视觉感知），下面的代码比你原有的实现更简洁高效，通过一次性写入整区域数据替代逐个单元格循环：

Public Sub PasteToFilteredCells_Simpler()
    Dim srcData As Variant
    Dim destAreas As Areas
    Dim area As Range
    Dim currentRow As Long
    Dim rowsToPaste As Long
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 临时表读取剪贴板数据到数组后立即删除
    With ThisWorkbook.Sheets.Add
        .Paste
        srcData = .UsedRange.Value
        .Delete
    End With
    
    Application.DisplayAlerts = True
    
    ' 获取所有可见区域块
    Set destAreas = Selection.SpecialCells(xlCellTypeVisible).Areas
    
    currentRow = 1
    
    ' 逐个区域批量写入数据
    For Each area In destAreas
        rowsToPaste = WorksheetFunction.Min(area.Rows.Count, UBound(srcData, 1) - currentRow + 1)
        If rowsToPaste <= 0 Then Exit For
        
        ' 一次性写入多行数据，效率远高于逐个单元格赋值
        area.Resize(rowsToPaste, UBound(srcData, 2)).Value = _
            Application.Index(srcData, Evaluate("row(" & currentRow & ":" & currentRow + rowsToPaste - 1 & ")"), 0)
        
        currentRow = currentRow + rowsToPaste
    Next area
    
    Application.ScreenUpdating = True
End Sub

内容的提问来源于stack exchange，提问作者Dume