Question

我想将数据从一张纸复制到另一张纸。

我将要复制的范围放到数组（LookupSource）中，因为在数组上工作比在单元格中循环要快。

在填充了二维数组（LookupSource）之后，我只想保留一些基于critieria的记录（列A = 10000），因此我尝试从LookupSource复制将此条件提取到二维的行数组（DataToCopy），它将复制到目标工作表。

我的问题是我无法做到这一点，因为似乎无法对第二个数组（DataToCopy）的第一个维度（行）进行动态调整大小。

有任何想法如何根据我的情况从LookupSource填充DataToCopy吗？

我得到的错误“索引超出范围”是在第ReDim Preserve DataToCopy(1 to j, 1 to 6)行

不是第一次，而是第二次在Next I之后进入For循环我想这是因为J是变量，并且不允许更改数组的第一维。

如何处理？

我在做什么更好的主意？

这里给我举个例子，只是我要复制的一小部分（我只用了8行，但实际上只有数千行）。我只想复制A列中具有10000的行。

这是我的代码

Dim LookupSource as Variant      
Dim DataToCopy() As Variant        
Dim i As Long
Dim j As Long


With MySheet
'MyRange is a defined name that reprensent column A, B, C, D, E, F
LookupSource = .Range(.Range("MyRange")(1, 1), .Range("MyRange")(8, 6)).Value2

j = 1

For i = LBound(LookupSource) To UBound(LookupSource)

If LookupSource(i, 1) = 10073 Then
ReDim Preserve DataToCopy(1 to j, 1 to 6)
DataToCopy(j, 1) = LookupSource(i, 1)
DataToCopy(j, 2) = LookupSource(i, 2)
DataToCopy(j, 3) = LookupSource(i, 3)
DataToCopy(j, 4) = LookupSource(i, 4)
DataToCopy(j, 5) = LookupSource(i, 5)
DataToCopy(j, 6) = LookupSource(i, 6)
j = j + 1
End If

Next i

end with

Answer 1

如何克服多维数组中ReDim Preserve的限制

如@ScottCraner所述，ReDim Preserve只能更改给定（数据字段）数组的最后一个维度。因此，尝试调整大小二维数组的第一维（=“行”）将失败。

但是，您可以使用Application.Index()（参见 [2] ）相对未知的过滤功能来克服这种不便，并从额外红利中获利更少的循环。

更多阅读：请参见Some pecularities of the Application.Index() function

Sub GetRowsEqual10000()
    With Sheet1
        Dim lastRow As Long:  lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        Dim rng     As Range: Set rng = .Range("A2:F" & lastRow)
    End With

    '[1] get data
    Dim data: data = rng

    '[2] rearrange data via Application.Index() instead ReDim Preserve plus loops
    data = Application.Index(data, ValidRows(data, Condition:=10000), Array(1, 2, 3, 4, 5, 6))
End Sub

帮助功能ValidRows（）

Function ValidRows(arr, Condition) As Variant
'Purpose: a) check condition (e.g. values equalling 10000) and b) get valid row numbers c) in a 2-dim vertical array
ReDim tmp(1 To UBound(arr))     ' provide for 1-based 2-dim array
Dim i As Long, ii As Long
For i = 1 To UBound(arr)                ' loop through 1st "column"
    If arr(i, 1) = Condition Then       '   a) check condition 
        ii = ii + 1: tmp(ii) = i        '   b) collect valid row numbers
    End If
Next i
ReDim Preserve tmp(1 To ii)             '   resize tmp array (here the 1st dimension is also the last one:) 
ValidRows = Application.Transpose(tmp)  ' c) return transposed result as 2-dim array
End Function

根据评论进行修改（2020-04-22）

简短提示Application.Index() 的最常使用：

经常使用Application.Index()函数来无需循环即可从2维数组中获取整个行或列数组。
像这样访问基于1的2维数据字段数组需要表示单行或列号，将邻居参数列或行号分别设置为0（零），这可能会导致例如

        Dim horizontal, vertical, RowNumber As Long, ColumnNumber As Long
    RowNumber = 17: ColumnNumber = 4
    horizontal = Application.Index(data, RowNumber, 0)
    vertical   = Application.Index(data, 0, ColumnNumber)

（直接寻址单个 array 元素，但是可以通过data(i,j) 而不是理论上的Application.Index(data, i, j)）

如何使用Application.Index()进行重组/过滤：

为了从Application.Index()的先进可能性中获利，您不仅需要传递数组名称（例如data），还需要将row |列参数作为数组传递，例如

    data = Application.Index(data, Application.Transpose(Array(15,8,10)), Array(1, 2, 3, 4, 5, 6))

请注意，行参数通过转置变为“垂直” 2维数组，其中Array(15,8,10) 甚至会改变现有的行顺序（在上面的示例代码中，这是在ValidRows()函数中的最后一行代码中完成的）。另一方面，列参数Array(1,2,3,4,5,6)保持“ flat” 或“ horizontal”，允许按原样获取所有现有列值。

因此您最终将收到给定元素索引内的任何数据元素（将它们视为图形中的坐标）。

Answer 2

范围查询功能

代码

Option Explicit

'START ****************************************************************** START'
' Purpose:      Filters a range by a value in a column and returns the result  '
'               in an array ready to be copied to a worksheet.                 '
'******************************************************************************'
Function RangeLookup(LookUpValue As Variant, LookupRange As Range, _
  Optional LookupColumn As Long = 1) As Variant

    Dim LookUpArray As Variant    ' LookUp Array
    Dim DataToCopy As Variant     ' DataToCopy (RangeLookup) Array
    Dim countMatch As Long        ' DataToCopy (RangeLookUp) Rows Counter
    Dim r As Long, c As Long      ' Row and Column Counters

    ' Check the arguments.
    Select Case VarType(LookUpValue)
         Case 2 To 8, 11, 17
         Case Else: Exit Function
    End Select
    If LookupRange Is Nothing Then Exit Function
    If LookupColumn < 1 Or LookupColumn > LookupRange.Columns.Count _
      Then Exit Function

    ' Copy values of Lookup Range to Lookup Array.
    LookUpArray = LookupRange

    ' Task: Count the number of values containing LookUp Value
    '       in LookUp Column of LookUp Array which will be
    '       the number of rows in DataToCopy Array.
    '       The number of columns in both arrays will be the same.

    ' Either:
    ' Count the number of values containing LookUp Value.
    countMatch = Application.WorksheetFunction _
      .CountIf(LookupRange.Columns(LookupColumn), LookUpValue)

    ' Although the previous looks more efficient, it should be tested.

'    ' Or:
'    ' Loop through rows of LookUpArray.
'    For r = 1 To UBound(LookUpArray)
'        ' Check if the value in current row in LookUp Column
'        ' is equal to LookUp Value.
'        If LookUpArray(r, LookupColumn) = LookUpValue Then
'            ' Increase DataCopy Rows Counter.
'            countMatch = countMatch + 1
'        End If
'    Next r

    ' Check if no match was found.
    If countMatch = 0 Then Exit Function

    ' Task: Write the matching rows in LookUp Array to DataToCopy Array.

    ' Resize DataToCopy Array to DataToCopy Rows counted in the previous
    ' For Next loop and the number of columns in Lookup Array.
    ReDim DataToCopy(1 To countMatch, 1 To UBound(LookUpArray, 2))
    ' Reset DataToCopy Rows Counter.
    countMatch = 0
    ' Loop through rows of LookUp Array.
    For r = 1 To UBound(LookUpArray)
        ' Check if the value in current row in LookUp Column
        ' is equal to LookUp Value.
        If LookUpArray(r, LookupColumn) = LookUpValue Then
            ' Increase DataCopy Rows Counter.
            countMatch = countMatch + 1
            ' Loop through columns of LookUp (DataToCopy) Array.
            For c = 1 To UBound(LookUpArray, 2)
                ' Write the current value of LookUp Array to DataToCopy Array.
                DataToCopy(countMatch, c) = LookUpArray(r, c)
            Next c
        End If
    Next r

    ' Write values from DataToCopy Array to RangeLookup Array.
    RangeLookup = DataToCopy

End Function
'END ********************************************************************** END'

您应该使用它，例如像这样：

Sub TryRangeLookup()

    Dim LookupRange As Range
    Dim DataToCopy As Variant

    With MySheet
    'MyRange is a defined name that reprensent column A, B, C, D, E, F
        Set LookupRange = .Range(.Range("MyRange")(1, 1), _
          .Range("MyRange")(8, 6)).Value2
    End With
    RangeLookUp 10073, DataCopy   
    If Not IsArray(DataToCopy) Then 
        MsgBox "No data found.": Exit Sub ' or whatever...
    Endif
    ' Continue with code...

End Sub

根据VBA中的条件将二维数组复制到另一个数组

2 个答案:

范围查询功能