VBA kennt Arrays. Doch vieles daran ist noch nicht sehr programmierfreundlich. Über die Jahre habe ich mir eine Sammlung versch. Hilfsfunktionen erstellt, die für mich die Arrays brauchbar machen

Für die Ausgabe einiger Resultate verwendete ich die Funktion [VBA] print_r()

Eine Callback-Funktion auf jedes Element eines Arrays anwenden → Die Funktion bekahm eine eigene Seite: [VBA] array_walk()

Ab und an braucht man ein Array<Variant>. Mit dieser Funktion kann man einen normalen Wertearray casten. Zusätzlich können die Werte versucht werden automatisch in in den eigentliche Typ zu casten (zu Variant/Double, Variant/String etc). Dazu werden die Funktionen isInteger() und isDouble() verwendet.

Public Sub testArray2Var()
    Dim s(-1 To 1)  As String
    Dim v()         As Variant
 
    s(-1) = "Negativ"
    s(0) = "Null"
    s(1) = "Positiv"
 
    print_r s
 
    v = array2Var(s)
    print_r v
End Sub

<String()> (
    [-1] => <String> 'Negativ'
    [0] => <String> 'Null'
    [1] => <String> 'Positiv'
)
<Variant()> (
    [-1] => <String> 'Negativ'
    [0] => <String> 'Null'
    [1] => <String> 'Positiv'
)

array2Var.bas

'/**
' * Convertiert ein Array in ein Variant-Array
' * @ressource              isInteger   http://wiki.yaslaw.info/dokuwiki/doku.php/vbvbafunctions#isinteger
' * @ressource              isDouble    http://wiki.yaslaw.info/dokuwiki/doku.php/vbvbafunctions#isdouble
' * @param  Array<>
' * @param  Boolean         Flag ob versucht werden soll, die Werte zu casten
' * @return Array<Variant>
' */
Public Function array2Var(ByRef iArray As Variant, Optional ByVal iCast As Boolean = True) As Variant()
    Dim i
    Dim ret() As Variant
On Error Resume Next
    ReDim ret(LBound(iArray) To UBound(iArray))
    For i = LBound(iArray) To UBound(iArray)
        If IsObject(iArray(i)) Then                 'Objekt
            Set ret(i) = CVar(iArray(i))
        ElseIf iCast And isInteger(iArray(i)) Then  'Integer
            ret(i) = CInt(iArray(i))
        ElseIf iCast And isDouble(iArray(i)) Then   'Double
            ret(i) = CDbl(iArray(i))
        ElseIf iCast And IsDate(iArray(i)) Then     'Datum
            ret(i) = CDate(iArray(i))
        Else                                        'String, Variant und der ganze Rest
            ret(i) = CVar(iArray(i))
        End If
    Next i
    array2Var = ret
End Function

Basierend auf array2var() ist dies eine Ableitung der split() Funktion von VBA. Sie gibt einfach ein Variant-Array anstelle des String-Arrays zurück.

split2Var.bas

'/**
' * @ressource      array2var() http://wiki.yaslaw.info/dokuwiki/doku.php/vbvbaarrayfunctions#array2var
' * @param          see: split()
' * @return         Array<Varaint>
' */
Public Function split2Var( _
        iExpression, _
        Optional ByVal iDelimiter As String = " ", _
        Optional ByVal iLimit As Long = -1, _
        Optional ByVal iCompare As VbCompareMethod = vbBinaryCompare _
    ) As Variant()
    split2Var = array2Var(split(iExpression, iDelimiter, iLimit, iCompare))
End Function

inArray.bas

'/**
' * Prüft ob ein Wert in einem Array vorhanden ist
' * http://wiki.yaslaw.info/wikka/VbVbaArrayFunctions#inArray
' * @param  Array
' * @param  Gesuchter Wert
' * @return Boolean
' * @example test_vorhanden = inArray(myArray, "test")
'*/
Private Function inArray(ByRef iArray As Variant, ByVal iValue As Variant) As Boolean
	Dim i As Long
 
On Error GoTo Err_Handler
	'Falls iArray kein initialisierter Array ist, gehts zur Fehlerbahndlung
	For i = LBound(iArray) To UBound(iArray)
		inArray = (iValue = iArray(i))
		If inArray Then GoTo Exit_Handler
	Next i
 
Exit_Handler:
	Exit Function
Err_Handler:
	'Array ist nicht initialisiert. Somit gibts kein Treffer
	inArray = False
	Resume Exit_Handler
End Function

isEmptyArray

'   /**
'    * IsEmptyArray
'    * @param   Array
'    * @return  true if Array is not initialized
'    */
Public Function isEmptyArray(ByVal iArray As Variant) As Boolean
  Dim Dummy As Long
 
  If IsArray(iArray) Then
 
	'Ggf. Fehler provozieren:
	On Error Resume Next
	Dummy = LBound(iArray)
 
	'Ergebnis bestimmen:
	IsEmptyArray = (Err.Number <> 0)
	On Error GoTo 0
 
  Else
 
	Err.Raise 13 'Type mismatch'
 
  End If
End Function

Fügt 2 Arrays zudammen

addArray

'   /**
'    * addArray
'    * Add Array2 to Array1
'    * @param   Array1
'    * @param   Array2
'    */
Public Sub addArray(ByRef ioArray As Variant, ByVal iArray As Variant)
	Dim i
	If Not IsEmptyArray(iArray) Then
		For i = 0 To UBound(iArray)
			Call pushArray(ioArray, iArray(i))
		Next i
	End If
 
End Sub

Fügt ein weiterer Wert am Ende des Arrays an

pushArray.bas

'   /**
'    * pushArray
'    * add Value to the Array
'    * @param   Array
'    * @param   Value
'    * @return  Ubound of the Array
'    */
Public Function pushArray(ByRef ioArray As Variant, ByRef iItem As Variant) As Long
    Dim nextI   As Long
 
    On Error Resume Next:
    ReDim Preserve ioArray(UBound(ioArray) + 1)
    If Err.Number <> 0 Then
        ReDim ioArray(0)
        Err.clear
    End If
    On Error GoTo 0
    If IsObject(iItem) Then
        Set ioArray(UBound(ioArray)) = iItem
    Else
        ioArray(UBound(ioArray)) = iItem
    End If
    pushArray = UBound(ioArray)
End Sub

arrayIndex

'   /**
'    * ArrayIndex
'   * 
'    * @param   Array
'   *  @param   Zu suchendes Element
'    * @return  Index des Eintages oder -1 falls das Element nicht im Array ist
'    */
Public Function arrayIndex( _
	ByRef iElement As Variant, _
	ByRef iArray As Variant _
  ) As Long
 
  If IsEmptyArray(iArray) Then
	ArrayIndex = -1
	Exit Function
  End If
  If IsObject(iElement) Then
 
	'Objekte vergleichen:
	For ArrayIndex = LBound(iArray) To UBound(iArray)
	  If IsObject(iArray(ArrayIndex)) _
	  Then If iElement Is iArray(ArrayIndex) _
		   Then Exit Function
	Next ArrayIndex
 
  Else
 
	'"Normale" Werte vergleichen:
	For ArrayIndex = LBound(iArray) To UBound(iArray)
	  If Not IsObject(iArray(ArrayIndex)) _
	  Then If iElement = iArray(ArrayIndex) _
		   Then Exit Function
	Next ArrayIndex
 
  End If
 
  'Kein Treffer:
  ArrayIndex = LBound(iArray) - 1
End Function

reDimArray

'   /**
'    * ReDimArray
'    * Vergrössert ein Array um [iStep] Schritte
'    * @param   Array
'    * @param   Schritte
'    * @param   UBound des neuen Arrays (wird als Referenz zurückgegeben)
'    * @return   Vergrösserter Array
'    */
Public Function reDimArray( _
		ByRef ioArray As Variant, _
		Optional ByVal iStep As Long = 1, _
		Optional ByRef oUbound As Long) _
As Variant
 
  If IsEmptyArray(ioArray) Then
	ReDim ioArray(iStep - 1)
  ElseIf UBound(ioArray) + iStep > -1 Then
	ReDim Preserve ioArray(UBound(ioArray) + iStep)
  End If
  ReDimArray = ioArray
  oUbound = UBound(ioArray)
 
End Function

arrayQuickSort

'http://www.vbarchiv.net/archiv/tipp_details.php?pid=372
Public Sub arrayQuickSort(ByRef ioArray As Variant, _
  Optional ByVal iStart As Variant, _
  Optional ByVal iEnd As Variant)
 
  ' Wird die Bereichsgrenze nicht angegeben,
  ' so wird das gesamte Array sortiert
 
  If IsMissing(iStart) Then iStart = LBound(ioArray)
  If IsMissing(iEnd) Then iEnd = UBound(ioArray)
 
  Dim i As Long
  Dim j As Long
  Dim h As Variant
  Dim x As Variant
 
  i = iStart: j = iEnd
  x = ioArray((iStart + iEnd) / 2)
 
  ' Array aufteilen
  Do
 
	While (ioArray(i) < x): i = i + 1: Wend
	While (ioArray(j) > x): j = j - 1: Wend
 
	If (i <= j) Then
	  ' Wertepaare miteinander tauschen
	  h = ioArray(i)
	  ioArray(i) = ioArray(j)
	  ioArray(j) = h
	  i = i + 1: j = j - 1
	End If
  Loop Until (i > j)
 
  ' Rekursion (Funktion ruft sich selbst auf)
  If (iStart < j) Then ArrayQuickSort ioArray, iStart, j
  If (i < iEnd) Then ArrayQuickSort ioArray, i, iEnd
End Sub

Wichtige Array-Funktionen von VBA join() split() ubound() redim preserve () Erase