Question

我正在尝试使用绑定到范围的列表框来加速旨在将人力资源分配到位置的应用程序。这很有效 - 丑陋的部分是使用find，copy和amp;将项目从一个数据范围移动到一个或多个范围。糊。

当我从webservices检索数据时，通过使用函数将数组打印到范围，我可以获得很快的速度，但我还是想不出如何替换find / cut / paste逻辑。

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

更新了样本

范围看起来像这样（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

除了搜索功能外，这并没有真正起作用。第一件事是提取一行并将其复制到一个新的，重新定尺寸的目标数组。最简单的方法是将目标重新定义为元素+ 1;然后做一些像（伪代码）推送到最后的事情：

vTargetArray(addedIndex) = vSourceArray(searchIndex)

第二件事似乎不容易就是删除一个密钥，但我还没有调查那么多的网络资源。

如果你能告诉我光明，我将非常感激。提前致谢，斯蒂芬

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

enter image description here

关注

如果你想要去，你可以把一些数据放在例如Sheet1 A1：E5和A6：E8左右，并创建vSourceArray = range（“A1：E5”）。Value2和vTargetArray（）= Range（“A6：E8”）。Value2并尝试在两者之间移动数据。这给了你类似的数组，就像我拥有它们一样。 - ExternalUse 1小时前

我按照你的建议做了，但采取了一种略微不同的方式来实现你想要的。同样出于测试目的，如下面的代码中所述，我已将lSearchKey视为2

<强> CODE ：

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

<强>快照

enter image description here

Excel VBA：将项目从一个数组移动到另一个数组

更新了样本

原帖，过时

1 个答案: