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

我想把数据从一张纸复制到另一张纸上

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

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

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

你知道如何根据我的情况从LookupSource中填充数据到copy吗

我得到的错误“索引超出范围”位于以下行：

ReDim Preserve DataToCopy（1到j，1到6）

不是在第一次，而是在第二次输入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

范围查找函数 代码

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'

---

如何克服多维数组中的

ReDim Preserve

限制

正如@ScottCraner所提到的，

ReDim Preserve

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

但是，应用相对未知的

Application.Index（）

（c.f.部分

[2]

）过滤功能，您可以克服这一不便，并从较少循环的额外好处中获益

进一步阅读：见

帮助功能

ValidRows

（）

---

因评论而编辑（2020-04-22）

最常用

Application.Index（）

的简短提示：

通常使用

Application.Index（）

函数 从二维数组中获取整个行或列数组，而无需循环。
像这样访问基于1的二维数据字段数组需要 指示单个行或列的编号，并 将相邻参数列或行号分别设置为

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)

（寻址单个数组元素将直接进行，但是通过

data（i，j）

而不是理论上的

应用程序。索引（数据，i，j）

）

如何使用

Application.Index（）

进行重组/筛选：

为了从

Application.Index（）

不仅需要将数组名（例如

数据

）传递，还需要将行|列参数作为数组传递，例如

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

请注意，rows参数通过换位变成“垂直”2维数组，其中

数组（15,8,10）

甚至会更改现有的行顺序 （在上面的示例代码中，这是在

ValidRows（）

函数的最后一行代码中完成的）。 另一方面，columns参数

数组（1,2,3,4,5,6）

保持“平坦”或“水平”且 允许按原样获取所有现有列值

因此，最终您将收到给定元素索引中的任何数据元素

---

（将它们视为图形中的坐标）

您只能调整数组的最后一个维度的大小。使用

Application.WorksheetFunction.CountIf（）

在循环之前设置数组的大小，您将不需要

ReDim Preserve

更好地过滤数据，复制可见单元格，然后将其粘贴到新的工作表上。更快的方法是什么？CountIf知道A列中有多少个数字为1000，或者过滤数据？那么如何只复制可见的部分呢？@ScottCraner我考虑过使用相同大小的源数组，当然我会在目标数组的末尾得到空白项，但是当我从一个数组复制到另一个数组时，它将不可见，因为它会复制单元格中的空值……你怎么看？那么，在这个想法和您提出的两个想法（CountIf/Filter）之间，哪一个更有效？非常感谢您的建议和努力，以这种方式循环还是使用CountIf来获得countMatch的数量更有效？在您的代码中，当您将数据重置为复制行计数器时，是否应该使用

countMatch=1

而不是

countMatch=0

？我们应该用

LookUpArray（r，1）

替换

LookUpArray（r，LookupColumn）

？@JustGreat:你让我有两个帐户，但countMatch保持为0，因为我在写之前正在计数。尝试在另一列中查找值时发现LookupColumn错误。谢谢。现在必须尝试此CountIf。再次感谢，将等待您关于CountIf的答案，但请告诉我您为什么添加了变量数据类型检查？@JustGreat:您可以安全地删除它，但我正在尝试使其防弹，以便您可以继续，例如：如果“DataToCopy=Empty，则退出Sub”。这是一种研究。如果这让您感到困扰，很抱歉。当然，另一方面，如果“DataToCopy”为空，您可能不知道原因。啊，利与弊。@JustGreat:我已经编辑了我的asnwer。这里有到的链接。我现在很忙。几小时后回来。祝你好运。这真的很有趣，非常感谢你提供的这些信息，但是我对Application.Index不是很了解。你能给我澄清一下吗？我所理解的是，它接受参数、数据、行和列，并且

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

        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)

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