Excel VBA : Move items from one array to another array

Question

我正在尝试使用绑定(bind)到范围的列表框来加速旨在将人力资源分配到位置的应用程序。这非常有效 - 丑陋的部分是使用查找、复制和粘贴将项目从一个数据范围移动到一个或多个范围。

当我从 web 服务检索数据时，我可以通过使用函数将数组打印到范围来提高速度，但我还不知道如何替换查找/剪切/粘贴逻辑。

我现在已经更新了我以前的帖子以包括我最近的尝试。以一种现在按预期工作的方式，但它看起来肯定不聪明:

更新示例

范围如下所示(Col 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

除了搜索功能外，这并不能真正发挥作用。第一件事是提取一行并将其复制到一个新的、重新确定尺寸的目标数组。最简单的方法是将目标重新调整为 elements + 1；然后做一些类似(伪代码)的事情将它推到最后:

vTargetArray(addedIndex) = vSourceArray(searchIndex)

第二件似乎并不容易的事情是删除 key ，但我还没有深入研究网络资源。

如果你能把灯给我，我将不胜感激。提前致谢，斯特凡

Answer 1

我们不需要临时数组来进行组合，但由于您使用的是临时数组 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 Sub

HTH

跟进

If you'd like to have a go, you could put some data in e.g. Sheet1 A1:E5, and A6:E8 or so, and create vSourceArray = range("A1:E5").Value2 and vTargetArray() = Range("A6:E8").Value2 and try to move data in between. That gives you similar arrays to work with as I have them. – ExternalUse 1 hour ago

我按照您的建议做了，但采用了稍微不同的方式来实现您想要的。同样出于测试目的，正如下面代码中所评论的，我将 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

快照