我想要实现的是一个动态宏,可以在许多不同的工作簿中使用它来实现以下目标:我想让用户输入他们想要复制的范围。该范围将被过滤。然后我想让用户选择范围来粘贴复制的数据。他们将粘贴到的范围也会被过滤(可能是与数据复制来源不同的过滤器。理想情况下,用户只需选择要粘贴到的范围的左上角单元格(而不是必须选择整个内容)。
下面的代码将按照我的意愿复制过滤后的数据(仅可见单元格)。
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
这提出了两个问题:
它仅正确粘贴到可见单元格上,但当前正在将“= CopyRange”作为文本输入到我想要粘贴的范围中(而不是将“粘贴单元格”设置为等于“复制单元格”的公式。
此代码尚不允许用户选择确切的范围。它允许他们选择一个起点,然后复制并粘贴到要粘贴到的列的末尾。我需要用户能够选择一个范围,但尚未找到一种方法来做到这一点而不发生错误。
在线搜索我发现了“粘贴到可见单元格宏”的其他版本。我尝试将它们与我在这篇文章中分享的第一段代码结合起来。这种组合如下所示。
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 行。
我还进行了其他几次尝试,但这些似乎是迄今为止最有希望的。任何人可以提供的任何建议/帮助将不胜感激。最大的关键是使其完全动态且对用户来说尽可能直观。
提前谢谢您!
我认为以下代码将实现您想要的功能:
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
备注:
它仅在您处理单列数据时才有效。即不要尝试使用跨越多列的源或目标范围。
可以将单个源单元格复制到单个目标单元格(有点无聊,但它会起作用),或复制到一系列目标单元格。
可以将一系列源单元格复制到单个目标单元格(在这种情况下,它将继续填充到所选单元格下方可见的任何行),或者复制到一系列目标单元格,前提是有相同的数量源中可见单元格的数量与目标中的可见单元格数相同。
尝试更改此行
RangeDest.Formula = "=RangeCopy"
到
RangeDest.Formula = ""=RangeCopy""
试试这个:
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