Question

我知道我可以通过Ctrl-G（转到）-特殊-仅可见单元来复制过滤的单元格。但是我无法复制已过滤的单元格并将其粘贴到另一组已过滤的单元格中。

我也知道我们可以使用结构化表格的填充功能来向上/向下/向左填充，它将跳过隐藏的单元格。但是使用这种方法，我无法将过滤后的单元格粘贴到自身上。而且我必须隐藏源和目标范围之间的列/行。并且它将覆盖目标单元格的格式。

是否有任何方法（包括VBA）将已过滤的单元格复制并仅将值粘贴到另一组已过滤的单元格（它们可以在相同范围内）？

Answer 1

通过使用Msgbox询问用户是否只希望粘贴值以及MyRange.Copy方法，我能够做到这一点。

Sub CopyPasteVisibleCells()
'This subroutine only handles copying visible cells in a SINGLE COLUMN

Dim RangeCopy As Range
Dim RangeDest As Range
Dim rng1 As Range
Dim dstRow As Long
Dim ValueOnly As Integer

'You should turn off screen updating and calculations here to increase speed

ValueOnly = MsgBox("Do you want to paste value only (yes) or the entire cell content (No)?", vbQuestion + vbYesNo + vbDefaultButton2, "Choose what to paste")

Set RangeCopy = Selection

Set RangeDest = Application.InputBox("Select range to paste onto ", "Obtain Range Object", Selection.Address, Type:=8)
    MsgBox "The range you have selected to paste onto is " & RangeDest.Address

If RangeCopy.Cells.Count > 1 Then
    If RangeDest.Cells.Count > 1 Then
        If RangeCopy.SpecialCells(xlCellTypeVisible).Count <> RangeDest.SpecialCells(xlCellTypeVisible).Count Then
            MsgBox "Data could not be copied"
            Exit Sub
        End If
    End If
End If

If ValueOnly = vbYes Then 'If user wants to copy value only
    If RangeCopy.Cells.Count = 1 Then
        'Copying a single cell to one or more destination cells
        For Each rng1 In RangeDest
            If rng1.EntireRow.RowHeight > 0 Then
                RangeDest.Value = RangeCopy.Value
            End If
        Next
    Else
        'Copying a range of cells to a destination range
        dstRow = 1
        For Each rng1 In RangeCopy.SpecialCells(xlCellTypeVisible)
            Do While RangeDest(dstRow).EntireRow.RowHeight = 0
                dstRow = dstRow + 1
            Loop
            RangeDest(dstRow).Value = rng1.Value
            dstRow = dstRow + 1
        Next
    End If
Else 'If user wants to copy all cell content
    If RangeCopy.Cells.Count = 1 Then
        'Copying a single cell to one or more destination cells
        For Each rng1 In RangeDest
            If rng1.EntireRow.RowHeight > 0 Then
                RangeCopy.Copy rng1
            End If
        Next
    Else
        'Copying a range of cells to a destination range
        dstRow = 1
        For Each rng1 In RangeCopy.SpecialCells(xlCellTypeVisible)
            Do While RangeDest(dstRow).EntireRow.RowHeight = 0
                dstRow = dstRow + 1
            Loop
            rng1.Copy RangeDest(dstRow)
            dstRow = dstRow + 1
        Next
    End If
End If


Application.CutCopyMode = False

'You can turn back on screen updating and calculations here

End Sub

复制过滤的单元格并将值仅粘贴到过滤的单元格中

1 个答案: