vba 如何复制不连续范围的并集并将它们粘贴到另一张纸中？
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/28280815/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
How to copy a union of discontinuous ranges and paste them into another sheet?
提问by Justin Moh
I've got a form in excel looks like this:
我在 excel 中有一个表格，如下所示：
E F G H ... N O P Q
* * * * * *
* * * * * *
* * *
* * *
* * *
T:* * * T:* * *
* * * * * *
* * * * * *
* * *
* * *
T:* * * T:* * *
* * *
* * *
T:* * *
It consists of many small areas with subtotals - rows indicated with "T".
它由许多带有小计的小区域组成 - 行用“T”表示。
Column E is "Price" and "F" is Qty, the rest of them is either formula calculated, or empty. So I've written a function to collect data from "E", which is initially what I had wanted.
E列是“价格”，“F”是数量，其余的要么是公式计算的，要么是空的。所以我编写了一个函数来从“E”收集数据，这正是我最初想要的。
But now I also wanted to get data from "F" and "H" as well, when "E" is validated.
但是现在我还想在验证“E”时从“F”和“H”获取数据。
My code was:
我的代码是：
Private Function CollectCellsData(dataRange As Range) As Range
Dim cell As Range, newRange As Range
For Each cell In dataRange
If Not cell.HasFormula = True And Not IsEmpty(cell.Value) Then
If newRange Is Nothing Then
Set newRange = cell
Else
Set newRange = Union(newRange, cell)
End If
End If
Next
Set CollectCellsData = newRange
End Function
Private Function CopyDataAndPaste(sSheet As Worksheet, sColumn As String, dSheet As Worksheet, dColumn As String)
Dim lastRow As Long
Dim dataRange As Range, newRange As Range
lastRow = sSheet.Cells(Rows.Count, sColumn).End(xlUp).Row
Set dataRange = sSheet.Range(sColumn & "3:" & sColumn & lastRow)
Set newRange = CollectCellsData(dataRange)
lastRow = dSheet.Cells(Rows.Count, dColumn).End(xlUp).Row
If Not newRange Is Nothing Then
newRange.Copy
dSheet.Range(dColumn & lastRow + 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
End Function
And I thought the most simple way to do it was simply alternate:
我认为最简单的方法就是交替：
Set newRange = Union(newRange, cell)
into:
进入：
Set newRange = Union(newRange, cell, cell.Offset(0,1), cell.Offset(0,3))
But apparently I was wrong. The error message is
但显然我错了。错误信息是
"Error 1004: Command cannot be used on multiple selection"
I think I've made a conceptional mistake. But if a
我想我犯了一个概念上的错误。但是如果一个
Union(range1, range2, range3)
would work with .Copy, why not in my case?
将与 .Copy 一起使用，为什么不能在我的情况下使用？
EDIT:
编辑：
My bad, after I change the code into
我的不好，在我将代码更改为
Set newRange = Union(newRange, cell, cell.Offset(0,1), cell.Offset(0,3))
There's an error occurred at line
线路发生错误
newRange.Copy
After the emphasis of Chrismas007that the Union() method should work, and a hint of msgbox rng.address for debugging, I'm now able to make it work. The problem was with the assignment of "newRange", not the second one but the initial assignment. Like what Gary's Studenthas implied, Union collects cells in a uniform way.
在Chrismas007强调Union() 方法应该可以工作，并提示 msgbox rng.address 用于调试之后，我现在可以让它工作了。问题在于“newRange”的分配，而不是第二个分配，而是初始分配。就像Gary 的学生所暗示的那样，Union 以统一的方式收集细胞。
'error
Set newRange = cell
'run
Set newRange = Union(cell, cell.Offset(0, 1), cell.Offset(0, 3))
Dropped programming for years and now I'm like the newbie 10 years ago!
放弃编程多年，现在我就像 10 年前的新手！
采纳答案by Chrismas007
If you Copy a range with multiple selections, you cannot paste it into a range with multiple selections. Therefore, you have to set your paste range as ONE CELL (That being the cell in the top left of the range) to clear the error.
如果复制具有多个选择的范围，则无法将其粘贴到具有多个选择的范围中。因此，您必须将粘贴范围设置为 ONE CELL（即范围左上角的单元格）以清除错误。
Test code:
测试代码：
Sub TestIt()
Dim Rng As Range
Set Rng = Union(Range("A1"), Range("B1"), Range("D1"))
Rng.Copy
'This code will error:
Rng.Offset(1, 0).PasteSpecial xlPasteValues
'This code will run:
Range("A2").PasteSpecial xlPasteValues
MsgBox Rng.Address
End Sub
回答by Gary's Student
It would be REALLY great to build a range of disjoint cells thru Union()and copy that range from one workbook to another, but Excel does not support that
通过Union()构建一系列不相交的单元格并将该范围从一个工作簿复制到另一个工作簿真的很棒，但 Excel 不支持
Say we are interested in the filled cells in columns E,F,G
假设我们对E、F、G列中的填充单元格感兴趣
But not the empty cells. Here we create the dijoint range and then copy cell-by-cell:
但不是空单元格。在这里，我们创建双联范围，然后逐个单元复制：
Sub CopyDisjoint()
Dim rBig As Range, rToCopy As Range, ady As String
Dim sh1 As Worksheet, sh2 As Worksheet
Dim r As Range
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
Set rBig = sh1.Range("E:H")
Set rToCopy = Intersect(rBig, sh1.Cells.SpecialCells(xlCellTypeConstants))
For Each r In rToCopy
ady = r.Address
r.Copy sh2.Range(ady)
Next r
End Sub
