我正在尝试使用绑定到范围的列表框来加速旨在将人力资源分配到位置的应用程序。这很好用——丑陋的部分是使用查找、复制和粘贴将项目从一个数据范围移动到一个或多个范围。
当我从 web 服务检索数据时，我可以通过使用函数将数组打印到范围来获得极快的速度，但我还不知道如何替换查找/剪切/粘贴逻辑。
我现在更新了我以前的帖子，包括我最近的尝试。以一种现在可以按预期工作的方式，但它肯定看起来并不聪明：
更新样本
范围看起来像这样（Col BE 中的数据不相关，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)
第二件看起来不太容易的事情是删除一个密钥，但我还没有对网络资源进行过太多调查。
如果你能给我看灯，我将不胜感激。在此先感谢，斯特凡
