Yaslaw.Info

This page is read only. You can view the source, but not change it. Ask your administrator if you think this is wrong.

======[VBA] Array Functions======
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 [[..:print_r:]]




=====array_walk()=====
Eine Callback-Funktion auf jedes Element eines Arrays anwenden
-> Die Funktion bekahm eine eigene Seite: [[..:array_walk]]
=====array2Var()=====
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.
==== Beipsiel ====
<code vb>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</code>
<code><String()> (
    [-1] => <String> 'Negativ'
    [0] => <String> 'Null'
    [1] => <String> 'Positiv'
)
<Variant()> (
    [-1] => <String> 'Negativ'
    [0] => <String> 'Null'
    [1] => <String> 'Positiv'
)</code>
==== Code ====
<code vb 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</code>

=====split2Var()=====
Basierend auf [[#array2var()]] ist dies eine Ableitung der split() Funktion von VBA.
Sie gibt einfach ein Variant-Array anstelle des String-Arrays zurück.
<code vb 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
</code>

=====inArray()=====

<code vb 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
</code>


=====isEmptyArray()=====

<code vb 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
</code>


=====addArray()=====
Fügt 2 Arrays zudammen
<code vb 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
</code>


=====pushArray()=====
Fügt ein weiterer Wert am Ende des Arrays an
<code vb 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
</code>
=====arrayIndex()=====
<code vb 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
</code>


=====reDimArray()=====
<code vb 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
</code>


=====arrayQuickSort()=====
<code vb 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
</code>

Wichtige Array-Funktionen von VBA
join()
split()
ubound()
redim preserve ()
Erase
{{tag>VBA Array}}
Yaslaw.Info

User Tools

Site Tools

Page Tools
