VB and VBA Users Source Code: Moving items in collections
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
Moving items in collections
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Monday, October 15, 2001
Hits:
681
Category:
Visual Basic General
Article:
The following code shows how to move/swap items in a collection. Option Explicit 'Purpose : Moves an item in a collection. 'Inputs : colMoveItem The collection to move the item in. ' vItem The item index or tag of the item to move. ' vMoveToItem The item or tag of the item to move to. ' [bMoveBefore] If True moves item vItem before vMoveToItem, else ' moves the item vItem after vMoveToItem. 'Outputs : Returns True if it successfully moves the item. 'Author : Andrew Baker 'Date : 08/01/2001 20:24 'Notes : Item tags will be lost if moving items by index. 'Revisions : Private Function CollectionMoveItem(colMoveItem As Collection, vItem As Variant, vMoveToItem As Variant, Optional bMoveBefore As Boolean = True) As Boolean Dim vItemIndexMoveTo As Variant, vItemIndexExisting As Variant Dim lStartPos As Long, lThisItem As Long, lEndPos As Long On Error GoTo ErrFailed If vItem <> vMoveToItem Then 'Get a reference to the item to move If CollectionGetItem(colMoveItem, vItem, vItemIndexExisting) Then 'Get a reference to the item to move to If CollectionGetItem(colMoveItem, vMoveToItem, vItemIndexMoveTo) Then 'Remove the item to move If VarType(vItem) = vbString Then colMoveItem.Remove CStr(vItem) Else colMoveItem.Remove CLng(vItem) End If 'Add the item to move back into the collection If VarType(vMoveToItem) = vbString Then 'Move items using Tags If bMoveBefore Then colMoveItem.Add vItemIndexExisting, CStr(vItem), CStr(vMoveToItem) Else colMoveItem.Add vItemIndexExisting, CStr(vItem), , CStr(vMoveToItem) End If Else 'Move an item near an item, based on an index If bMoveBefore Then If vMoveToItem < vItem Then colMoveItem.Add vItemIndexExisting, , CLng(vMoveToItem) Else 'We have removed item vItem which is below the vMoveToItem index, so 'we have to subtract one from the vMoveToItem index colMoveItem.Add vItemIndexExisting, , CLng(vMoveToItem) - 1 End If Else If vMoveToItem < vItem Then colMoveItem.Add vItemIndexExisting, , , CLng(vMoveToItem) Else 'We have removed item vItem which is below the vMoveToItem index, so 'we have to subtract one from the vMoveToItem index colMoveItem.Add vItemIndexExisting, , , CLng(vMoveToItem) - 1 End If End If End If CollectionMoveItem = True End If End If End If Exit Function ErrFailed: Debug.Print "Error in CollectionMoveItem: " & Err.Description CollectionMoveItem = False End Function 'Purpose : Finds and returns an item in a collection. 'Inputs : colGetItem The collection to find the item in. ' vItem The key or index of the item. ' [vItemFound] See outputs. 'Outputs : Returns True if it successfully finds the item. ' [vItemFound] The item found in the collection. 'Author : Andrew Baker 'Date : 08/01/2001 20:24 'Notes : 'Revisions : Private Function CollectionGetItem(colGetItem As Collection, vItem As Variant, Optional vItemFound As Variant) As Boolean On Error GoTo ErrFailed 'Get a reference to the item to move If VarType(vItem) = vbString Then If VarType(colGetItem.Item(CStr(vItem))) = vbObject Then Set vItemFound = colGetItem.Item(CStr(vItem)) Else vItemFound = colGetItem.Item(CStr(vItem)) End If Else If VarType(colGetItem.Item(CLng(vItem))) = vbObject Then Set vItemFound = colGetItem.Item(CLng(vItem)) Else vItemFound = colGetItem.Item(CLng(vItem)) End If End If CollectionGetItem = True Exit Function ErrFailed: CollectionGetItem = False Debug.Print "Error in CollectionGetItem: " & Err.Description End Function Sub Test() Dim colAlphabet As Collection, lThisChar As Long Set colAlphabet = New Collection For lThisChar = 65 To 90 colAlphabet.Add Chr$(lThisChar), Chr$(lThisChar) Next CollectionMoveItem colAlphabet, "A", "Z" 'Move the item A before Z CollectionMoveItem colAlphabet, 1, 2, False 'Move the item 1 before 2 (swap B and C) End Sub
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
