仅复制可见单元格并粘贴到仅可见单元格动态宏

Question

我想要完成的是一个动态宏，可以在许多不同的工作簿中使用它来实现以下目的：我想让用户输入一个他们想要复制的范围。该范围将被过滤。然后我想让用户 select 范围粘贴复制的数据。他们将粘贴到的范围也被过滤（可能与数据复制来源的过滤器不同。理想情况下，用户只会 select 要粘贴到的范围的左上角单元格（而不是必须 select 整个事情）。

下面的代码将按照我的意愿复制过滤后的数据（仅限可见单元格）。

Dim RangeCopy As Range
Dim RangeDest As Range

Set RangeCopy = Application.InputBox("Select a range to copy ", "Obtain     Range Object", Type:=8)
    MsgBox "The range you selected to copy is " & RangeCopy.Address
        RangeCopy.Select

Selection.SpecialCells(xlCellTypeVisible).Select 'selects visible cells only from previously selected range
    Selection.Copy

粘贴当然是棘手的部分。我发现我可以通过以下方式手动 "paste" 成功：

假设复制范围为A1:A10，粘贴范围为B10:B20

我可以将公式“= A1”输入单元格 B10 ---> 复制单元格 B10 ----> select 粘贴到所需的范围 ----> 使用 "Alt ;"快捷方式---->粘贴。

以下代码尝试在 VBA 中自动执行此逻辑：

Dim RangeCopy As Range
Dim RangeDest As Range

Set RangeCopy = Application.InputBox("Select top cell of range to copy ", "Obtain Range Object", Type:=8)
    MsgBox "The top cell of the range you would like to copy is " & RangeCopy.Address


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

RangeDest.Formula = "=RangeCopy"
RangeDest.Copy

Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
    ActiveSheet.Paste

Application.CutCopyMode = False
Calculate

这会带来两个问题：

它仅正确粘贴到可见单元格上，但它当前正在将“=CopyRange”作为文本输入到我要粘贴到的范围内（而不是公式设置 "paste cell" 等于"copy cell".
此代码还不允许用户 select 和精确范围。它允许他们以 select 为起点，然后将复制并粘贴到被粘贴到的列的末尾。我需要用户能够 select 一个范围，但还没有找到一种方法来做到这一点而不会发生错误。

在线搜索我找到了 "pasting onto visible cells macros" 的其他版本。我尝试将它们与我在此 post 中分享的第一段代码结合起来。这种组合如下所示。

Sub Copy_Paste_Visible_Cells()

Dim RangeCopy As Range
Dim RangeDest As Range

Set RangeCopy = Application.InputBox("Select a range to copy ", "Obtain     Range Object", Type:=8)
    MsgBox "The range you selected to copy is " & RangeCopy.Address
        RangeCopy.Select

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

Selection.SpecialCells(xlCellTypeVisible).Select 'selects visible cells only from previously selected range
Selection.Copy

Dim rng1 As Range
Dim rng2 As Range

    For Each rng2 In RangeDest
        If rng2.EntireRow.RowHeight > 0 Then
            rng2.PasteSpecial
            Set RangeDest = rng2.Offset(1).Resize(RangeDest.Rows.Count)
            Exit For
        End If
    Next

Application.CutCopyMode = False

End Sub

这可以正常运行，但宏只会粘贴到遇到隐藏行为止。因此，如果第 1,2、3 和 6 行可见但隐藏了 4 和 5，则宏将粘贴到 1,2 和 3 而不是 4,5 或 6。

我已经做了其他几次尝试，但这些似乎是迄今为止最有希望的。非常感谢任何人可以提供的任何建议/帮助。最大的关键是使它完全动态，并尽可能直观地呈现给用户。

提前致谢！

Answer 1

尝试更改此行

  RangeDest.Formula = "=RangeCopy"

至

  RangeDest.Formula = ""=RangeCopy""

Answer 2

我认为下面的代码会做你想做的事：

Sub Copy_Paste_Visible_Cells()
    '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

    Set RangeCopy = Application.InputBox("Select a range to copy ", "Obtain     Range Object", Type:=8)
        MsgBox "The range you selected to copy is " & RangeCopy.Address

    Set RangeDest = Application.InputBox("Select range to paste onto ", "Obtain Range Object", 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 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

    Application.CutCopyMode = False
End Sub

备注：

它仅在您处理单列数据时才有效。即不要尝试使用跨越多列的源或目标范围。
可以将单个源单元格复制到单个目标单元格（有点无聊，但它会起作用），或者复制到一系列目标单元格。
可以将一系列源单元格复制到单个目标单元格（在这种情况下，它将继续填充到所选单元格下方可见的任何行），或复制到一系列目标单元格单元格，前提是源中的可见单元格数量与目标中的可见单元格数量相同。

仅复制可见单元格并粘贴到仅可见单元格动态宏

Copy only visible cells and paste onto only visible cells dynamic macro

vba

excel

macros

visible