使用简单的命令（无循环）使用 VBA 从非连续范围的联合中获取值到数组中
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/18993915/
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
Get values from union of non-contiguous ranges into array with VBA with a simple command (no loops)
提问by Floris
I have the following (on the surface of it, simple) task:
我有以下（从表面上看，很简单）任务：
Copy the values from a number of columns on a spreadsheet into a 2D array using VBA.
使用 VBA 将电子表格上多列中的值复制到二维数组中。
To make life more interesting, the columns are not adjacent, but they are all of the same length. Obviously one could do this by looping over every element in turn, but that seems very inelegant. I am hoping there is a more compact solution - but I struggle to find it.
为了让生活更有趣，这些列并不相邻，但它们的长度都相同。显然可以通过依次循环每个元素来做到这一点，但这似乎很不雅观。我希望有一个更紧凑的解决方案 - 但我很难找到它。
Here are some attempts of what I would consider "a simple approach" - for simplicity, I am putting the range as A1:A5, D1:D5- a total of 10 cells in two ranges.
以下是我认为是“简单方法”的一些尝试 - 为简单起见，我将范围设为A1:A5, D1:D5- 两个范围内总共 10 个单元格。
Private Sub testIt()
Dim r1, r2, ra, rd, rad
Dim valString, valUnion, valBlock
Set r1 = Range("A1:A5")
Set r2 = Range("D1:D5")
valString = Range("A1:A5,D1:D5").Value
valUnion = Union(r1, r2).Value
valBlock = Range("A1:D5").Value
End Sub
When I look at each of these variables, the first two have dimension (1 To 5, 1 To 1)while the last one has (1 To 5, 1 To 4). I was expecting to get (1 To 5, 1 To 2)for the first two, but that was not the case.
当我查看这些变量中的每一个时，前两个具有维度，(1 To 5, 1 To 1)而最后一个具有(1 To 5, 1 To 4). 我原以为会得到(1 To 5, 1 To 2)前两个，但事实并非如此。
I would be happy if I could loop over the data one column at the time, and assign all the values in one column to one column in the array - but I could not figure out how to do that either. Something like
如果我当时可以遍历一列的数据，并将一列中的所有值分配给数组中的一列，我会很高兴 - 但我也无法弄清楚如何做到这一点。就像是
cNames = Array("A", "D")
ci = 1
For Each c in columnNames
vals( , ci) = Range(c & "1:" & c & "5").Value
ci = ci + 1
Next c
But that's not the right syntax. The result I want to get would be achieved with
但这不是正确的语法。我想要的结果将实现
cNames = Array("A", "D")
ci = 1
For Each c in columnNames
For ri = 1 To 5
vals(ri , ci) = Range(c & "1").offset(ri-1,0).Value
Next ri
ci = ci + 1
Next c
But that's pretty ugly. So here is my question:
但这太丑了。所以这是我的问题：
Is it possible to get the values of a "composite range" (multiple non-contiguous blocks) into an array - either all at once, or a columns at a time? If so, how do I do it?
是否可以将“复合范围”（多个非连续块）的值放入数组中 - 一次全部或一次列？如果是这样，我该怎么做？
For extra bonus points - can anyone explain why the arrays returned in testIt()are dimensioned Base 1, whereas my VBA is set to Option Base 0? In other words - why are they not (0 To 4, 0 To 0)? Is this just one more inconsistency on the part of Microsoft?
对于额外的奖励积分 - 任何人都可以解释为什么返回的数组testIt()是维度的Base 1，而我的 VBA 设置为Option Base 0？换句话说 - 为什么不是(0 To 4, 0 To 0)？这只是微软方面的又一个不一致之处吗？
回答by Tim Williams
Provided each area in rnghas the same number of rows then this should work.
如果每个区域rng具有相同的行数，那么这应该可以工作。
Function ToArray(rng) As Variant()
Dim arr() As Variant, r As Long, nr As Long
Dim ar As Range, c As Range, cnum As Long, rnum As Long
Dim col As Range
nr = rng.Areas(1).Rows.Count
ReDim arr(1 To nr, 1 To rng.Cells.Count / nr)
cnum = 0
For Each ar In rng.Areas
For Each col In ar.Columns
cnum = cnum + 1
rnum = 1
For Each c In col.Cells
arr(rnum, cnum) = c.Value
rnum = rnum + 1 'EDIT: added missing line...
Next c
Next col
Next ar
ToArray = arr
End Function
Usage:
用法：
Dim arr
arr = ToArray(Activesheet.Range("A1:A5,D1:D5"))
Debug.Print UBound(arr,1), UBound(arr,2)
As for why array from rng.Valueare 1-based instead of zero-based, I'd guess it's because that maps more readily to actual row/column numbers on the worksheet than if it were zero-based. The Option Base xsetting is ignored
至于为什么数组 fromrng.Value是基于 1 而不是基于零的，我猜是因为它比从零开始更容易映射到工作表上的实际行/列号。该Option Base x设置将被忽略
回答by Chris D
It is possible to accomplish what you want if you're willing to add a hidden worksheet. I used Excel 2010 and created two worksheets (Sheet1 / Sheet2) to test my findings. Below is the code:
如果您愿意添加隐藏的工作表，则可以完成您想要的操作。我使用 Excel 2010 并创建了两个工作表 (Sheet1 / Sheet2) 来测试我的发现。下面是代码：
Private Sub TestIt()
' Src = source
' Dst = destination
' WS = worksheet
Dim Data As Variant
Dim SrcWS As Excel.Worksheet
Dim DstWS As Excel.Worksheet
' Get a reference to the worksheet containing the
' source data
Set SrcWS = ThisWorkbook.Worksheets("Sheet1")
' Get a reference to a hidden worksheet.
Set DstWS = ThisWorkbook.Worksheets("Sheet2")
' Delete any data found on the hidden worksheet
DstWS.UsedRange.Columns.EntireColumn.Delete
' Copy the non-contiguous range into the hidden
' worksheet.
SrcWS.Range("A1:A5,D1:D5").Copy DstWS.Range("A1")
' Now all of the data can be stored in a variable
' as a 2D array because it will be contiguous on
' the hidden worksheet.
Data = DstWS.UsedRange.Value
End Sub
回答by Erdrick
Tim,
蒂姆，
Thanks for your sample code. I had some problems with it and had to rewrite some portions of it. It wasn't counting through the rows and columns correctly. I have test this and it is working 100%
感谢您的示例代码。我遇到了一些问题，不得不重写其中的某些部分。它没有正确计算行和列。我已经测试过了，它 100% 工作
Function ToArray(rng As Range) As Variant()
Dim arr() As Variant, r As Long, nr As Long
Dim ar As Range, c As Range, cnum As Long, rnum As Long
Dim col As Range
Dim lastrow As Integer
Dim saverow() As Integer
Dim lastcolumn As Integer
Dim templastcolumn As Integer
For i = 1 To rng.Areas.Count
templastcolumn = (rng.Areas(i).Column + rng.Areas(i).CountLarge) - 1
If lastrow <> rng.Areas(i).Row Then
nr = nr + rng.Areas(i).Rows.Count
lastrow = rng.Areas(i).Row
End If
If lastcolumn < templastcolumn Then lastcolumn = templastcolumn
Next i
ReDim arr(1 To nr, 1 To lastcolumn)
ReDim saverow(1 To lastrow)
cnum = 0
rnum = 0
lastrow = 0
For Each ar In rng.Areas
If lastrow <> ar.Row Then
lastrow = ar.Row
cnum = 0
End If
For Each col In ar.Columns
cnum = cnum + 1
For Each c In col.Cells
If saverow(c.Row) = 0 Then
rnum = rnum + 1
saverow(c.Row) = rnum
End If
arr(saverow(c.Row), cnum) = c.value
Next c
Next col
Next ar
ToArray = arr
End Function
Sub TestCopyArray()
Dim arr As Variant
arr = ToArray(ThisWorkbook.Sheets("MSS").Range("B1:D2,G1:J2,B4:D4,B6:D6"))
ThisWorkbook.Sheets("Sheet1").Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub
