AW: Inhalte eines Arrays in ein anderes Array kopi
07.06.2008 05:33:29
fcs
Hallo Karsten,
bei meiner 1. Anwort fehleten leider die Makros in der Datei.
Hier jetzt die der VBA-Code.
Ich hab noch etwas optimiert.
Die Daten des ErgebnisArray werden in ein Temporäres Array mit 6 Spalten geschrieben und dann zusammen mit der Sortierreihenfolge und Sortierart an eine Sub-routine übergeben.
Diese Sortiert das Temporäre Array, dessen Daten dann in der Hauptroutine weiterverarbeitet werden können.
Für andere Sortierungen müssen nur die Arrays für Spalten und Sortierart angepasst werden.
Gruß
Franz
'Globale Variablen
Public Type Ergebnisse
spt As Integer
Verein As String
Punkte As Integer
TG As Integer
TK As Integer
TD As Integer
End Type
Sub aaaTest()
'In einer Sub Prozedur ist das Array nun wie folgt deklariert.
Dim ErgebnisArray(1 To 34) As Ergebnisse
Dim spt As Long, Verein, Punkte, Tore_geschossen, Tore_kassiert, Tordifferenz
Dim a, b
Dim Zeile As Long, spalte As Long, strSort As String
Dim PlazierungArray() As Ergebnisse, ArrayTemp()
'Anschließend fülle ich mit diversen Berechnungen dieses Array und kann die Werte ausgeben.
'Alle Daten in das Array "Ergebnisse" einlesen
GoTo Weiter01
With ErgebnisArray(spt)
.spt = spt
.Verein = Verein(a, b)
.Punkte = Punkte(a, b)
.TG = Tore_geschossen(a, b)
.TK = Tore_kassiert(a, b)
.TD = Tordifferenz(a, b)
Debug.Print .spt, .Punkte, .TG, .TK, .TD, .Verein
End With
Weiter01:
'Testdaten einlesen
For Zeile = 2 To 35
With ErgebnisArray(Zeile - 1)
.spt = Cells(Zeile, 1)
.Verein = Cells(Zeile, 2)
.Punkte = Cells(Zeile, 3)
.TG = Cells(Zeile, 4)
.TK = Cells(Zeile, 5)
.TD = Cells(Zeile, 6)
Debug.Print .spt, .Punkte, .TG, .TK, .TD, .Verein
End With
Next
'Daten in temporäres Array einlesen
ReDim ArrayTemp(LBound(ErgebnisArray) To UBound(ErgebnisArray), 1 To 6)
ReDim PlazierungArray(LBound(ErgebnisArray) To UBound(ErgebnisArray))
For Zeile = LBound(ErgebnisArray) To UBound(ErgebnisArray)
ArrayTemp(Zeile, 1) = ErgebnisArray(Zeile).spt
ArrayTemp(Zeile, 2) = ErgebnisArray(Zeile).Verein
ArrayTemp(Zeile, 3) = ErgebnisArray(Zeile).Punkte
ArrayTemp(Zeile, 4) = ErgebnisArray(Zeile).TG
ArrayTemp(Zeile, 5) = ErgebnisArray(Zeile).TK
ArrayTemp(Zeile, 6) = ErgebnisArray(Zeile).TD
Next
'Array nach Spalten 3,6,4 / Punkte,TD, TG jeweils absteigend sortieren
strSort = SortArray(arrWerte:=ArrayTemp, varReihenfolge:=Array(3, 6, 4), _
varAufsteigend:=Array(False, False, False))
If strSort "" Then
MsgBox strSort
Else
'Daten ins Plazierungsarray schreiben
For Zeile = LBound(PlazierungArray) To UBound(PlazierungArray)
With PlazierungArray(Zeile)
.spt = ArrayTemp(Zeile, 1)
.Verein = ArrayTemp(Zeile, 2)
.Punkte = ArrayTemp(Zeile, 3)
.TG = ArrayTemp(Zeile, 4)
.TK = ArrayTemp(Zeile, 5)
.TD = ArrayTemp(Zeile, 6)
Debug.Print .spt, .Punkte, .TG, .TK, .TD, .Verein
End With
Next
'Daten in Tabelle schreiben
Zeile = 2
spalte = 12
For spt = LBound(ArrayTemp) To UBound(ArrayTemp)
Cells(Zeile, spalte) = ArrayTemp(spt, 1) 'spt
Cells(Zeile, spalte + 1) = ArrayTemp(spt, 2) 'Verein
Cells(Zeile, spalte + 2) = ArrayTemp(spt, 3) 'Punkte
Cells(Zeile, spalte + 3) = ArrayTemp(spt, 4) 'TG
Cells(Zeile, spalte + 4) = ArrayTemp(spt, 5) 'TK
Cells(Zeile, spalte + 5) = ArrayTemp(spt, 6) 'TD
Zeile = Zeile + 1
Next
End If
ReDim ArrayTemp(0)
End Sub
Function SortArray(arrWerte As Variant, varReihenfolge As Variant, _
varAufsteigend As Variant) As String
'Sortieren eines mehr-spaltigen 2-dimesionalen Arrays
'Erstellt: fcs 2008-06-07
'Excel-Version: 97
'arrWerte = 2-dimensionales Array
'varReihenfolge = Angabe der Sortierreihenfolge mit den Spaltennummern als Array
'varAufsteigen = Angabe der Sortierung als Array, False=absteigend, True=Aufsteigend
Dim intSort As Integer 'Schleifenzähler für die Sortierreihenfolge
Dim arrSort() 'In diesem Array wird die neue Reihenfolge aus der Sortierung erstellt
Dim arrTempWerte() 'Speichert die Werte des gesamten Arrays vor dem nächsten Sortierlauf
Dim arrVergleich() 'Speichert die Werte aus der zu vergleichenden Spalte
Dim arrTemp() 'Speichert die Vergleichswerte in der neuen Reihenfolge
Dim lngZA&, lngZE& 'Long-Variablen - Array-Größe-Zeilen
Dim lngSA&, lngSE& 'Long-Variablen - Array-Größe-Spalten
Dim lngI&, lngJ&, lngK&, lngF&, lngTemp& 'Long-Variablen - Schleifenzähler
Dim bolVergleich As Boolean
On Error GoTo Fehler
'Prüfung der Parameter
If UBound(arrWerte, 1) = LBound(arrWerte, 1) Then
'Das Datenfeld enthält nur eine Zeile keine Sortierung
GoTo Fehler
End If
If Not IsArray(arrWerte) Then SortArray = "Die übergebenen Daten sind kein Array"
'Anzahl Sortierparameter im Array
If UBound(varReihenfolge) UBound(varAufsteigend) Then
SortArray = SortArray & vbLf & "Die Variablen ""varReihenfolge"" und ""varAufsteigend""" _
& " müssen die gleiche Anzahl Werte im Array haben!"
End If
'Spaltennummern im Array
For lngI = LBound(varReihenfolge) To UBound(varReihenfolge)
If IsNumeric(varReihenfolge(lngI)) Then
If varReihenfolge(lngI) UBound(arrWerte, 2) Then
SortArray = SortArray & vbLf & "Die Nummer(n) der zu sortierende(n) Spalte(n) " _
& " müssen innerhalb der Spaltennummern des Arrays liegen!"
Exit For
End If
Else
SortArray = SortArray & vbLf & "Für die Reihenfolge der zu sortierende(n) Spalte(n) " _
& " dürfen nur ganze Zahlen angegeben werden!"
Exit For
End If
Next
'True/False im Array
For lngI = LBound(varAufsteigend) To UBound(varAufsteigend)
If IsNumeric(varAufsteigend(lngI)) Then
If Not (varAufsteigend(lngI) = True Or varAufsteigend(lngI) = False) Then
SortArray = SortArray & vbLf & "Die Werte für die Sortierung dürfen nur " _
& " den Wert False oder True haben!"
Exit For
End If
Else
SortArray = SortArray & vbLf & "Die Werte für die Sortierung dürfen nur " _
& " den Wert False oder True haben!"
Exit For
End If
Next
If SortArray "" Then GoTo Fehler
'Array-Größen einlesen
'Zeilen
lngZA = LBound(arrWerte, 1)
lngZE = UBound(arrWerte, 1)
'Spalten
lngSA = LBound(arrWerte, 2)
lngSE = UBound(arrWerte, 2)
'Sortier-Reihenfolge in umgekehrter Reihenfolge des Arrays abarbeiten
For intSort = UBound(varReihenfolge) To LBound(varReihenfolge) Step -1
'Temporäre Arrays redimensionieren und so auf Null setzen
ReDim arrTempWerte(lngZA To lngZE, lngSA To lngSE)
ReDim arrVergleich(lngZA To lngZE)
ReDim arrSort(lngZA To lngZE)
ReDim arrTemp(lngZA To lngZE)
'Aktuelle Werte und die Werte der Vergleichsspalte in Arrays einlesen
For lngI = lngZA To lngZE
For lngJ = lngSA To lngSE
arrTempWerte(lngI, lngJ) = arrWerte(lngI, lngJ)
Next
arrVergleich(lngI) = arrWerte(lngI, varReihenfolge(intSort))
Next
'Zeilezähler-Startwert für temporäres Array setzen und Werte einlesen
lngTemp = lngZA
arrSort(lngTemp) = lngZA
arrTemp(lngTemp) = arrVergleich(lngTemp)
'2 bis letzten Wert des Arrays vergleichen
For lngI = lngZA + 1 To lngZE
bolVergleich = False
' Vergleichswert mit den Werten im Temporären/Sortierten Array vergleichen
For lngK = lngZA To lngTemp
If (varAufsteigend(intSort) = False And arrTemp(lngK) arrVergleich(lngI)) Then
'vorhandene Daten im temporären Array und Sortier-Array _
ab Position um eins im Array verschieben
For lngF = lngTemp + 1 To lngK + 1 Step -1
arrTemp(lngF) = arrTemp(lngF - 1)
arrSort(lngF) = arrSort(lngF - 1)
Next
'Vergleichswert an Position einfügen
arrTemp(lngK) = arrVergleich(lngI)
'Zeilennummer im Sortierarray an Position eintragen
arrSort(lngK) = lngI
bolVergleich = True
Exit For
End If
Next
'Temp-Zähler um 1 erhöhen
lngTemp = lngTemp + 1
If bolVergleich = False Then
'Vergleichswert in Temp-Array eintragen
arrTemp(lngTemp) = arrVergleich(lngI)
'Zeile des Vergleichswertes im Sort-Array eintragen
arrSort(lngTemp) = lngI
End If
Next
'Daten in neuer Sortierung zurückschreiben
For lngI = lngZA To lngZE
For lngJ = lngSA To lngSE
arrWerte(lngI, lngJ) = arrTempWerte(arrSort(lngI), lngJ)
Next
Next
Next
SortArray = ""
Fehler:
If Err.Number 0 Then
If SortArray "" Then SortArray = SortArray & vbLf
SortArray = SortArray & "Fehler Nr. " & Err.Number _
& " ist in Function "" SortArray"" aufgetreten!" & vbLf & Err.Description
End If
' Variablen aufräumen
ReDim arrTempWerte(0)
ReDim arrVergleich(0)
ReDim arrSort(0)
ReDim arrTemp(0)
End Function