Question

我有以下（表面上看，简单）任务：

使用VBA将电子表格中多列的值复制到2D数组中。

为了让生活更有趣，列不相邻，但它们的长度都相同。显然，人们可以依次循环遍历每个元素，但这似乎非常不优雅。我希望有一个更紧凑的解决方案 - 但我很难找到它。

以下是我会考虑的一些尝试＆＃34;一种简单的方法＆＃34; - 为简单起见，我将范围设为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

当我查看每个变量时，前两个变量的维度为(1 To 5, 1 To 1)，而最后一个变量的变量为(1 To 5, 1 To 4)。我希望前两个获得(1 To 5, 1 To 2)，但事实并非如此。

如果我能够在一列中循环数据，并将一列中的所有值分配到数组中的一列，我会很高兴 - 但我也无法弄清楚如何做到这一点。像

这样的东西

cNames = Array("A", "D")
ci = 1
For Each c in columnNames
  vals( , ci) = Range(c & "1:" & c & "5").Value
  ci = ci + 1
Next c

但那不是正确的语法。我希望得到的结果将通过

实现

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

但那很难看。所以这是我的问题：

是否可以获得＆＃34;复合范围的值＆＃34; （多个非连续的块）到一个数组中 - 要么一次全部，要么一次一列？如果是这样，我该怎么做？

对于额外的奖励积分 - 任何人都可以解释为什么在testIt()中返回的数组的尺寸为Base 1，而我的VBA设置为Option Base 0？换句话说 - 他们为什么不(0 To 4, 0 To 0)？这只是微软的另一个不一致吗？

Answer 1

如果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

用法：

Dim arr
arr = ToArray(Activesheet.Range("A1:A5,D1:D5"))
Debug.Print UBound(arr,1), UBound(arr,2)

至于为什么来自rng.Value的数组是从1开始而不是从0开始的，我猜这是因为它更容易映射到工作表上的实际行/列数，而不是从零开始。忽略Option Base x设置

Answer 2

如果您愿意添加隐藏的工作表，则可以完成您想要的操作。我使用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

Answer 3

添

感谢您的示例代码。我有一些问题，不得不重写它的一些部分。它没有正确计算行和列。我测试了这个，它正在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

使用简单命令（无循环）从非连续范围的并集获取值到VBA数组

3 个答案: