AW: Array kürzen
14.03.2014 13:16:43
fcs
Hallo Frank,
ein Weg besteht darin die letzte Zelle mit Werte im Bereich zu suchen und dann mit dem kleineren Bereichen weiter zu arbeiten.
Nachfolgend ein Beispiel.
Gruß
Franz
Sub prctest()
Dim A
A = fncArrayXY(rngX:=ActiveSheet.Range("A2:A500"), rngY:=ActiveSheet.Range("B2:B500"))
End Sub
Function fncArrayXY(rngX As Range, rngY As Range) As Variant
Dim arrX, arrY
Dim rngXneu As Range, rngYneu As Range
Dim rngZelle As Range, Zeile As Long
fncArrayXY = "Fehler"
'letzte Zelle mit Inhalt im X-Zellbereich
Set rngZelle = rngX.Cells.Find(what:="*", after:=rngX.Cells(1, 1), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rngZelle Is Nothing Then
MsgBox "keine Daten im x-WerteBereich!"
GoTo Beenden
Else
Set rngXneu = rngX.Parent.Range(rngX.Range("A1"), rngZelle)
End If
'letzte Zelle mit Inhalt im Y-Zellbereich
Set rngZelle = rngY.Cells.Find(what:="*", after:=rngY.Cells(1, 1), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rngZelle Is Nothing Then
MsgBox "keine Daten im y-WerteBereich!"
GoTo Beenden
Else
Set rngYneu = rngY.Parent.Range(rngY.Range("A1"), rngZelle)
End If
'ggf. Konsistenz der Daten prüfen
If rngXneu.Rows.Count rngYneu.Rows.Count Then
MsgBox "Datenbereiche für X- und Y-Werte haben unterschiedliche Anzahl werte!!"
GoTo Beenden
End If
arrX = rngXneu
arrY = rngYneu
'Arrays verarbeiten
fncArrayXY = 0
If rngXneu.Rows.Count = 1 Then
fncArrayXY = arrX * arrY + arrX - arrY
Else
For Zeile = LBound(arrX, 1) To UBound(arrX, 1)
fncArrayXY = fncArrayXY + (arrX(Zeile, 1) * arrY(Zeile, 1)) + arrX(Zeile, 1) _
- arrY(Zeile, 1)
Next
'Arrays wieder leeren
Erase arrX, arrY
End If
Beenden:
Set rngXneu = Nothing: Set rngYneu = Nothing: Set rngZelle = Nothing
End Function