3

範囲にバインドされたリストボックスを使用して、人材を場所に割り当てるように設計されたアプリケーションを高速化しようとしています。これは非常にうまく機能します。醜い部分は、検索、コピー、貼り付けを使用して、1 つのデータ範囲から 1 つまたは複数の範囲にアイテムを移動することです。

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)

簡単ではないように見える 2 番目のことは、キーの削除ですが、私はまだ Web リソースをあまり調査していません。

光を見せていただければ幸いです。前もってありがとう、ステファン

4

1 に答える 1

4

結合を行うために一時配列は必要ありませんが、一時配列を使用しているため、それが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

ここに画像の説明を入力

ファローアップ

試してみたい場合は、Sheet1 A1:E5 や A6:E8 などにデータを入れて、vSourceArray = range("A1:E5").Value2 および vTargetArray() = Range( を作成します。 "A6:E8").Value2 の間でデータを移動しようとします。これにより、私が持っているのと同様の配列を使用できます。– ExternalUse 1 時間前

私はあなたが提案したようにしましたが、あなたが望むものを達成するために少し異なる方法を取りました. また、テスト目的で、以下のコードでコメントされているように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

スナップショット

ここに画像の説明を入力

于 2012-04-12T11:30:43.257 に答える