我想将数据从一张纸复制到另一张纸。
我将要复制的范围放到数组(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
答案 0 :(得分: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”,
允许按原样获取所有现有列值。
因此您最终将收到给定元素索引内的任何数据元素 (将它们视为图形中的坐标)。
答案 1 :(得分:0)
代码
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