7

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

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

为了让生活更有趣，这些柱子并不相邻，但它们的长度都是一样的。显然，可以通过依次遍历每个元素来做到这一点，但这似乎非常不雅。我希望有一个更紧凑的解决方案 - 但我很难找到它。

以下是我认为“一种简单方法”的一些尝试——为简单起见，我将范围设置为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

但这很丑陋。所以这是我的问题：

是否可以将“复合范围”（多个非连续块）的值放入数组中 - 一次全部或一次列？如果是这样，我该怎么做？

对于额外的奖励积分 - 谁能解释为什么返回的数组testIt()是有尺寸的Base 1，而我的 VBA 设置为Option Base 0？换句话说——他们为什么不(0 To 4, 0 To 0)呢？这只是微软方面的又一个不一致之处吗？

4

3 回答 3

16

如果每个区域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)

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

于 2013-09-25T00:18:28.307 回答
1

如果您愿意添加隐藏的工作表，则可以完成您想要的。我使用 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
于 2017-10-02T20:42:44.557 回答
0

蒂姆，

感谢您的示例代码。我遇到了一些问题，不得不重写它的某些部分。它没有正确计算行和列。我已经对此进行了测试，并且它可以 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
于 2016-12-23T17:52:42.950 回答