VBA实现数组Array与集合Collection互换

分类:代码, 博客 标签:

数组和集合在VBA中是常用的数据类型,这里水文具工集在VBA中实现数组Array与集合Collection的相互转换,编写了两个通用的过程ArrayToCollection与CollectionToArray,方便程序中调用,具体源代码如下:

数组转换到集合ArrayToCollection

'================================
' VBA数组转换到集合ArrayToCollection
'
' http://www.cnhup.com
'================================

Public Function ArrayToCollection( _
  Arr As Variant, ByRef Coll As Collection) _
  As Boolean
Dim Ndx As Long
Dim KeyVal As String

If IsArray(Arr) = False Then
    ArrayToCollection = False
    Exit Function
End If

On Error GoTo ErrH:
Select Case NumberOfArrayDimensions(Arr:=Arr)
    Case 0
        ArrayToCollection = False
        Exit Function
        
    Case 1
        For Ndx = LBound(Arr) To UBound(Arr)
            Coll.Add Item:=Arr(Ndx)
        Next Ndx
    
    Case 2
        For Ndx = LBound(Arr, 1) To UBound(Arr, 1)
            KeyVal = Arr(Ndx, 1)
            If Trim(KeyVal) = vbNullString Then
                Coll.Add Item:=Arr(Ndx, 1)
            Else
                Coll.Add Item:=Arr(Ndx, 0), Key:=KeyVal
            End If
        Next Ndx
    
    Case Else
        ArrayToCollection = False
        Exit Function

End Select

ArrayToCollection = True
Exit Function

ErrH:
    ArrayToCollection = False

End Function

集合转换到数组CollectionToArray

'================================
' VBA集合转换到数组CollectionToArray
'
' http://www.cnhup.com
'================================

Public Function CollectionToArray( _
  Coll As Collection, Arr As Variant) _
  As Boolean
Dim V As Variant
Dim Ndx As Long

If Coll Is Nothing Then
    CollectionToArray = False
    Exit Function
End If

If IsArray(Arr) = False Then
    CollectionToArray = False
    Exit Function
End If
If IsArrayDynamic(Arr:=Arr) = False Then
    CollectionToArray = False
    Exit Function
End If

If Coll.Count < 1 Then
    CollectionToArray = False
    Exit Function
End If
    
ReDim Arr(1 To Coll.Count)

For Ndx = 1 To Coll.Count
    If IsObject(Coll(Ndx)) = True Then
        Set Arr(Ndx) = Coll(Ndx)
    Else
        Arr(Ndx) = Coll(Ndx)
    End If
Next Ndx

CollectionToArray = True

End Function


分类:代码, 博客 标签:

发表评论

You must be logged in to post a comment.