仅复制可见单元格并粘贴到仅可见单元格dynamicmacros

我想要完成的是一个dynamic的macros，可以在许多不同的工作簿中使用以实现以下function：我想让用户input他们想要复制的范围。 这个范围将被过滤。 然后我想让用户select范围来粘贴复制的数据。 他们将粘贴到的范围也被过滤（可能是不同于数据被复制的filter）。IDEALLY用户只会select范围的左上angular的单元格来粘贴（而不必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 

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

假定复制范围是A1：A10，粘贴范围是B10：B20

可以在单元格B10中input公式“= A1”—>复制单元格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 

这提出了两个问题：

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

2. 此代码不允许用户select和确切的范围。 它允许他们select一个起点，然后复制并粘贴到被粘贴的列的末尾。 我需要用户能够select一个范围，还没有find一种方式来做到这一点，而不会出现错误。

在网上search我发现了其他版本的“粘贴到可见单元格macros”。 我试图把他们与我在这篇文章中共享的第一位代码结合起来。 这个组合如下所示。

 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 

这运行没有错误，但macros只粘贴，直到它击中隐藏的行。 所以，如果行1,2,3和6是可见的，但4和5是隐藏的，macros将粘贴到1,2和3，但不是4,5或6。

我做了几个其他的尝试，但这些似乎是迄今为止最有希望的。 任何build议/任何人都可以提供帮助，非常感谢。 最大的关键是使用户能够完全dynamic和直观。

先谢谢你 ！

Answer 1

我认为下面的代码将做你想要的：

 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. 一系列源单元格可以复制到单个目标单元格（在这种情况下，它将继续填充选定单元格下方可见的任何行），或者提供给目标单元格的范围，以提供相同数量的可见源中的单元格与目标中的单元格一样。

Answer 2

尝试改变这一行

  RangeDest.Formula = "=RangeCopy" 

至

  RangeDest.Formula = ""=RangeCopy""