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

问题描述 投票：0回答：3

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

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

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

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

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

我可以在单元格 B10 中输入公式“= A1” ---> 复制单元格 B10 ----> 选择要粘贴到的所需范围 ----> 使用“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

这提出了两个问题：

  1. 它仅正确粘贴到可见单元格上，但当前正在将“= CopyRange”作为文本输入到我想要粘贴的范围中（而不是将“粘贴单元格”设置为等于“复制单元格”的公式。

  2. 此代码尚不允许用户选择确切的范围。它允许他们选择一个起点，然后复制并粘贴到要粘贴到的列的末尾。我需要用户能够选择一个范围，但尚未找到一种方法来做到这一点而不发生错误。

在线搜索我发现了“粘贴到可见单元格宏”的其他版本。我尝试将它们与我在这篇文章中分享的第一段代码结合起来。这种组合如下所示。 

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 行。

我还进行了其他几次尝试，但这些似乎是迄今为止最有希望的。任何人可以提供的任何建议/帮助将不胜感激。最大的关键是使其完全动态且对用户来说尽可能直观。

提前谢谢您！

vba excel macros visible
3个回答
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

备注：

  1. 它仅在您处理单列数据时才有效。即不要尝试使用跨越多列的源或目标范围。

  2. 可以将单个源单元格复制到单个目标单元格（有点无聊，但它会起作用），或复制到一系列目标单元格。

  3. 可以将一系列源单元格复制到单个目标单元格（在这种情况下，它将继续填充到所选单元格下方可见的任何行），或者复制到一系列目标单元格，前提是有相同的数量源中可见单元格的数量与目标中的可见单元格数相同。

0
投票

尝试更改此行

  RangeDest.Formula = "=RangeCopy"

到

  RangeDest.Formula = ""=RangeCopy""
0
投票

试试这个：

    Public Sub Copy_Range_Paste_Into_Visible_Cells()

    Dim rngSource As Range, rngDestination As Range, cell As Range, cc As Long, i As Long
    
    On Error Resume Next
    Application.DisplayAlerts = False
    
    Set rngSource = Application.InputBox("Select the filtered range to copy. ", "Select Filtered Cells", Type:=8)
    If rngSource Is Nothing Then Application.DisplayAlerts = True: Exit Sub   'User canceled
    
    Set rngDestination = Application.InputBox("Select the destination cell to paste to. ", "Select Paste Destination", Type:=8)
    If rngDestination Is Nothing Then Application.DisplayAlerts = True: Exit Sub  'User canceled
    
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    cc = rngSource.Columns.Count
    
    Application.Calculation = xlCalculationManual    'additional sub procedure
    
    For Each cell In rngSource.Columns(1).SpecialCells(xlCellTypeVisible)
        Do Until Not rngDestination(1).Offset(i).EntireRow.Hidden
            i = i + 1
        Loop
        rngDestination(1).Offset(i).Resize(1, cc).Value = cell.Resize(1, cc).Value
        i = i + 1
    Next
    
    Application.Calculation = xlCalculationAutomatic     'additional sub procedure
    
End Sub
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.