Excel VBA:将项从一个数组移动到另一个数组
Excel VBA:将项从一个数组移动到另一个数组
提问于 2012-04-12 17:09:24
我正在尝试使用绑定到范围的列表框来加速设计为将人力资源分配到位置的应用程序。这非常有效-丑陋的部分是使用查找、复制和粘贴将项目从一个数据范围移动到一个或多个范围。
当我从yet服务检索数据时，我可以通过使用一个函数将数组打印到范围来获得很大的速度，但是我还不知道如何替换查找/剪切/粘贴逻辑。
我现在已经更新了我之前的帖子，包括我最近的尝试。在某种程度上，它现在可以像预期的那样工作，但看起来肯定不明智：
更新的示例
范围如下所示( B-E列中的数据不相关，A包含关键字)。Day0_lbUsers是A1:E5，Day1_lbUsers是A28:E30。
A B C D E
1 15 Foo Bar Bas Nono
2 18 Foo Bar Bas Nono
3 19 Foo Bar Bas Nono
4 196 Foo Bar Bas Nono
5 33 Foo Bar Bas Nono
...
28 32 Foo Bar Bas Nono
29 46 Foo Bar Bas Nono
30 52 Foo Bar Bas Nono在本例中，我想将带有键18的行从Day0_lbUsers移动到Day1_lbUsers。在示例中，我对源代码进行了硬编码，并没有写回范围，但这并不是最难的部分。我很感兴趣的是，是否有更好的方法来传输数组内容。
Sub TestRemoveFromArray()
Dim vSourceArray() As Variant ' source
Dim vNewSourceArray() As Variant ' source, one key removed
Dim vTargetArray() As Variant ' target
Dim vNewTargetArray() As Variant ' target, one item added
Dim rowSearch As Long, row As Long, col As Long, search As Long, blnFound As Boolean
search = 18
vSourceArray = shData.Names("Day0_lbUsers").RefersToRange.Value2 ' 27 rows, 5 columns, key in col 1
' loop source to find the row that contains the search key
For rowSearch = LBound(vSourceArray) To UBound(vSourceArray)
' look into col 1 for the key
If vSourceArray(rowSearch, 1) = search Then
blnFound = True
Exit For
End If
Next rowSearch
If Not blnFound Then
Exit Sub
End If
' we've found the row, so let's get the target
vTargetArray = shData.Names("Day1_lbUsers").RefersToRange.Value2
' a1 needs to be 1 short of a, b1 must be b +1
ReDim vNewSourceArray(LBound(vSourceArray) To UBound(vSourceArray) - 1, 1 To 5)
ReDim vNewTargetArray(LBound(vTargetArray) To UBound(vTargetArray) + 1, 1 To 5)
' copy original target to new target
For row = LBound(vTargetArray) To UBound(vTargetArray)
For col = LBound(vTargetArray, 2) To UBound(vTargetArray, 2)
vNewTargetArray(row, col) = vTargetArray(row, col)
Next col
Next row
' reset blnFound
blnFound = False
For row = LBound(vSourceArray) To UBound(vSourceArray)
If row = rowSearch Then
For col = LBound(vSourceArray, 2) To UBound(vSourceArray, 2)
vNewTargetArray(UBound(vNewTargetArray), col) = vSourceArray(row, col)
Next col
blnFound = True
Else
For col = LBound(vSourceArray, 2) To UBound(vSourceArray, 2)
' if blnFound was found before, write to the key -1
vNewSourceArray(IIf(blnFound, row - 1, row), col) = vSourceArray(row, col)
Next col
End If
NextRow:
Next row
'assign new arrays (return later)
vSourceArray = vNewSourceArray
Erase vNewSourceArray
vTargetArray = vNewTargetArray
Erase vNewTargetArray
End Sub原始帖子，过期
所有数据区域都具有相同的列数(5)，并被命名。这就是我到目前为止所拥有的；在某种程度上，我不得不停止编程，转而使用伪代码来进行说明。源数组和目标数组是用例如
vSourceArray = shData.Names("Day0_A").RefersToRange.Value2 ' (1 to 27, 1 to 5)
Private Function MoveUserId(ByRef vSourceArray() As Variant, ByRef vTargetArray() As Variant, lngUserId As Long) As Boolean
Dim lSearchKey As Long, blnFound As Boolean, col As Long
Dim vTempArray() As Variant, vRow() As Variant
For lSearchKey = LBound(vSourceArray) To UBound(vSourceArray)
If vSourceArray(lSearchKey, 1) = lngUserId Then
blnFound = True
Exit For
End If
Next lSearchKey
If blnFound = False Then
MoveUserId = False
Exit Function
End If
' extract the row found
ReDim vRow(1 To 1) As Variant
vRow(1) = Application.WorksheetFunction.index(vSourceArray, lSearchKey)
' now, add an item to targetarray and populate using a function from http://www.cpearson.com
vTargetArray = CombineTwoDArrays(vTargetArray, vRow) ' does not work
' now delete the key in source array
' help!
End Function除了搜索功能之外，这并不能真正起作用。第一件事是提取一行，并将其复制到一个新的、重新确定维度的目标数组中。最简单的方法是将目标重定向为元素+ 1；然后执行一些类似(伪代码)的操作，将其推送到末尾：
vTargetArray(addedIndex) = vSourceArray(searchIndex)第二件看起来并不容易的事情是删除一个键，但我还没有调查过那么多的web资源。
如果你能给我指一下灯，我将不胜感激。提前谢谢你，斯特凡
回答 1
Stack Overflow用户
回答已采纳
发布于 2012-04-12 19:30:43
我们不需要临时数组来进行合并，但由于您使用的是临时数组vRow，让我也使用一个来说明它是如何工作的:)请参阅此示例
Sub Sample()
Dim Ar1(), Ar2(), Ar3()
Dim i As Integer
Ar1() = Array("A", "B", "C", "D")
Ar2() = Array("1", "2", "3", "4")
ReDim Preserve Ar3(1)
Ar3(1) = Ar1(1)
'Debug.Print "Ar3 >> "; Ar3(1)
ReDim Preserve Ar2(UBound(Ar2) + 1)
Ar2(UBound(Ar2)) = Ar3(1)
For i = 0 To UBound(Ar2)
Debug.Print "Ar2 >> "; Ar2(i)
Next i
End SubHTH
后续
如果你想尝试一下，你可以在Sheet1 A1:E5和A6:E8中放入一些数据，然后创建vSourceArray = range("A1:E5").Value2
vTargetArray() = Range("A6:E8").Value2，然后尝试在两者之间移动数据。这为您提供了类似的数组，就像我使用它们一样。-1小时前的ExternalUse
我按照你的建议做了，但采取了一种略有不同的方式来实现你想要的东西。同样出于测试目的，正如在下面的代码中注释的那样，我将lSearchKey设为2
代码
Option Explicit
Sub Sample()
Dim Ar1() As String, Ar2() As String, Ar3() As String
Dim Rng1 As Range, Rng2 As Range
Dim ws As Worksheet
Dim i As Long, j As Long
Set ws = Sheets("Sheet1")
With ws
Set Rng1 = .Range("A1:E5")
Set Rng2 = .Range("A6:E8")
'~~> Redim Ar2 and Ar3 arrays
ReDim Ar2(Rng2.Rows.Count, Rng2.Columns.Count)
ReDim Ar3(0, Rng2.Columns.Count)
'~~> Store Range 2 in Ar2
For i = 0 To Rng2.Rows.Count - 1
For j = 0 To Rng2.Columns.Count - 1
Ar2(i, j) = Rng2.Cells(i + 1, j + 1)
'Debug.Print Ar2(i, j)
Next j
Next i
'~~> Manually setting the Search Key for testing purpose
Dim lSearchKey As Long
lSearchKey = 2
'~~> Adding the relevant data from Ar2 to Ar3
For i = 0 To Rng2.Columns.Count - 1
Ar3(0, i) = Ar2(lSearchKey - 1, i)
'Debug.Print Ar3(1, i)
Next
'~~> Redim the 1st Array
ReDim Preserve Ar1(Rng1.Rows.Count, Rng1.Columns.Count)
'~~> Store Range 1 in Ar1
For i = 0 To Rng1.Rows.Count - 1
For j = 0 To Rng1.Columns.Count - 1
Ar1(i, j) = Rng1.Cells(i + 1, j + 1)
'Debug.Print Ar1(i, j)
Next j
Next i
'~~> Store the Ar3 into Ar1
For i = 0 To Rng2.Columns.Count - 1
Ar1(UBound(Ar1), i) = Ar3(0, i)
Debug.Print ">>"; Ar1(UBound(Ar1), i)
Next i
End With
End Sub快照
页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/10120606
复制相关文章
相似问题