Live-Forum - Die aktuellen Beiträge
Datum
Titel
15.04.2024 23:32:21
Darstellung im IMAGE sehr schlecht
15.04.2024 21:08:34
PDF mit Makro erstellen mehrere Sheets
15.04.2024 18:38:39
Arbeitszeiten Vorlage ergänzen
15.04.2024 17:34:30
Fehlende Zeilen automatisch nach Zeiten ergänzen
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
840to844
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
840to844
840to844
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Makro Lineare Interpolation (und Extrapolation)

Makro Lineare Interpolation (und Extrapolation)
26.01.2007 11:49:21
Doro
Hallo Zusammen,
ich habe eine Funktion, welche zwei Spalten einliest, und als Ergebnis einen interpolierten (oder auch extrapolierten) Wert ausgibt (siehe Quelltext unten). Das funktioniert auch, wenn die beiden Spalten komplett ausgefüllt sind, oder wenn die ersten Einträge ausgefüllt sind, und dann leere Zellen kommen. Ich habe aber die folgende Formel in der Zelle:
=WENN(ODER(ISTLEER(C5);ISTLEER(D5);ISTLEER(E5));"";D5-E5)
Dadurch wird in der Zelle zwar nichts angezeigt, aber die Funktion liefert als Fehlerwert #WERT!. Ich vermute, dass die Zelle nicht als leer erkannt wird.
Hat jemand ne Idee, wie man das Makro dahingehend ändern kann, dass es auch bei eigentlich leeren Zellen, in denen Formeln stehen, funktioniert?
Viele Grüße,
Doro
Public 

Function LIP(xVector As Range, yVector As Range, xValue As Long)
Dimension = xVector.Cells.Count
If xValue < xVector.Cells(1).Value Or xValue > xVector.Cells(Dimension).Value Then
If xValue < xVector.Cells(1).Value Then
m = (yVector.Cells(2) - yVector.Cells(1)) / (xVector.Cells(2) - xVector.Cells(1))
n = yVector.Cells(2) - m * xVector.Cells(2)
Else
m = (yVector.Cells(Dimension) - yVector.Cells(Dimension - 1)) / (xVector.Cells(Dimension) - xVector.Cells(Dimension - 1))
n = yVector.Cells(Dimension) - m * xVector.Cells(Dimension)
End If
LIP = m * xValue + n
Else
For i = 2 To Dimension
If xValue <= xVector.Cells(i).Value Then Exit For
Next i
LIP = yVector.Cells(i - 1).Value _
+ (xValue - xVector.Cells(i - 1).Value) / (xVector.Cells(i).Value - xVector.Cells(i - 1).Value) _
* (yVector.Cells(i).Value - yVector.Cells(i - 1).Value)
End If
End Function

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro Lineare Interpolation (und Extrapolation)
26.01.2007 14:44:48
fcs
Hallo Doro,
ich weiss jetzt nicht ob diese Lösung 100% zufriedenstellend ist, aber folgende Modifikationen sollten helfen, weiter zu kommen. ggf. müsstest du die Fehlerroutine verfeinern oder noch genauer formulieren wie die Interpolation erfolgen soll wenn der Algorithmus auf eine Zelle mit Leerstring trifft.
1. Ändere die Formel in den Zellen

=WENN(ODER(ISTFEHLER(D5-E5);ISTLEER(C5);ISTLEER(D5);ISTLEER(E5));"";D5-E5)

Dies unterdrückt die #WERT!-Anzeige.
2. Passe das Makro mit einer Fehlerbehandlung an. Dadurch kommt als Ergebnis "Interpolationsfehler", wenn einer der Werte, der für die Interpolationsberechnung benutzt wird ein Leerstring ist. Der Fehler wird dadurch ausgelöst, dass versucht wird Texte zu addieren/subtrahieren. Das mag Excel/VBA nicht so gern.

Function LIP(xVector As Range, yVector As Range, xValue As Long)
Dimension = xVector.Cells.Count
On Error GoTo Fehler
If xValue < xVector.Cells(1).Value Or xValue > xVector.Cells(Dimension).Value Then
If xValue < xVector.Cells(1).Value Then
m = (yVector.Cells(2) - yVector.Cells(1)) / (xVector.Cells(2) - xVector.Cells(1))
n = yVector.Cells(2) - m * xVector.Cells(2)
Else
m = (yVector.Cells(Dimension) - yVector.Cells(Dimension - 1)) / (xVector.Cells(Dimension) - xVector.Cells(Dimension - 1))
n = yVector.Cells(Dimension) - m * xVector.Cells(Dimension)
End If
LIP = m * xValue + n
Else
For i = 2 To Dimension
If xValue <= xVector.Cells(i).Value Then Exit For
Next i
LIP = yVector.Cells(i - 1).Value _
+ (xValue - xVector.Cells(i - 1).Value) / (xVector.Cells(i).Value - xVector.Cells(i - 1).Value) _
* (yVector.Cells(i).Value - yVector.Cells(i - 1).Value)
End If
Exit Function
Fehler:
LIP = "Interpolationsfehler"
End Function

Warum deklarierst du den Paramter xValue in der Zeile
Function LIP(xVector As Range, yVector As Range, xValue As Long)
als Long. Wäre hier Double nicht besser? Oder gibst du für xValue immer nur ganze Zahlen ein? Im Moment werden eingegebene xValues mit Nachkommstellen auf Ganze Zahlen umgerechnet.
Gruß
Franz
Anzeige
AW: Makro Lineare Interpolation (und Extrapolation)
26.01.2007 14:54:34
Doro
Hallo Franz,
erstmal vielen Dank, ich dachte schon, es meldet sich gar keiner :-)
zu 1: Die #WERT! Fehlermeldung kommt nur als Ergebnis der LIP Funktion, mit der Formel hab ich kein Problem
zu 2: Double als Variablentyp ist besser, da ist das GAnze flexibler (obwohl ich zur Zeit nur ganzzahlige Eingaben habe). ABER: Ich will ja trotzdem interpolieren. Vielleicht kann ich als erstes die Anzahl der nicht leeren Zellen in xVector und yVector ermitteln, davon das Minimum nehmen, und dann die For-Schleife (im unteren Bereich) nur bis zu diesem Minimum laufen lassen? Nur, wie mach ich das?
Schöne Grüße,
Doro
Anzeige
AW: Makro Lineare Interpolation (und Extrapolation
27.01.2007 02:05:57
fcs
Hallo Doro,
ich habe deine Function LIP mal verfeinert um Wertepaare zu erkennen, die einen Leerstring enthalten. Bei der Interpolation werden solche Wertepaare "überbrückt" und der nächste belegte Wert unter bzw. oberhalb in die Inter-/Extrapolation eingesetzt.
Gruss
Franz

Function LIP(xVector As Range, yVector As Range, xValue As Double)
Dim Dimension As Long, MinDim As Long, MaxDim As Long
Dim I_oben As Long, I_unten As Long, I As Long
Dimension = xVector.Cells.Count
On Error GoTo Fehler
'1. X-Y-Wertepaar bestimmen, das verschieden ist von Leerstring
For I = 1 To Dimension
If xVector(I) <> "" And yVector(I) <> "" Then MinDim = I: Exit For
Next
'letztes X-Y-Wertepaar bestimmen, das verschieden ist von Leerstring
For I = Dimension To 1 Step -1
If xVector(I) <> "" And yVector(I) <> "" Then MaxDim = I: Exit For
Next
If xValue < xVector.Cells(MinDim).Value Or xValue > xVector.Cells(MaxDim).Value Then
'Extrapolation der Werte
If xValue < xVector.Cells(MinDim).Value Then
'Nächstes X-Y-Wertepaar mit Werten verschieden von Leerstring
For I = MinDim + 1 To Dimension
If xVector(I) <> "" And yVector(I) <> "" Then Exit For
Next
m = (yVector.Cells(I) - yVector.Cells(MinDim)) / (xVector.Cells(I) - xVector.Cells(MinDim))
n = yVector.Cells(I) - m * xVector.Cells(I)
Else
'Vorletztes X-Y-Wertepaar mit Werten verschieden von Leerstring
For I = MaxDim - 1 To MinDim Step -1
If xVector(I) <> "" And yVector(I) <> "" Then Exit For
Next
m = (yVector.Cells(MaxDim) - yVector.Cells(I)) / (xVector.Cells(MaxDim) - xVector.Cells(I))
n = yVector.Cells(MaxDim) - m * xVector.Cells(MaxDim)
End If
LIP = m * xValue + n
Else
'Interpolation der Werte
'X-Y-Wertepaar mit X-Wert >= gesuchten X-Wert
For I = MinDim + 1 To MaxDim
If xValue <= xVector.Cells(I).Value And yVector(I) <> "" Then I_oben = I: Exit For
Next I
'Vorheriges X-Y-Wertepaar mit Werten verschieden von Leerstring
For I = MaxDim - 1 To MinDim Step -1
If xVector(I) <> "" And yVector(I) <> "" Then I_unten = I: Exit For
Next
LIP = yVector.Cells(I_unten).Value _
+ (xValue - xVector.Cells(I_unten).Value) / _
(xVector.Cells(I_oben).Value - xVector.Cells(I_unten).Value) _
* (yVector.Cells(I_oben).Value - yVector.Cells(I_unten).Value)
End If
Exit Function
Fehler:
LIP = "Interpolationsfehler"
End Function

Anzeige
AW: Makro Lineare Interpolation (und Extrapolation
29.01.2007 10:46:40
Doro
Hallo Franz,
danke erstmal!! Aber irgendwie funktioniert es nicht :-( Wenn ich als x-Vektor die Werte 0, 20 und 40 habe, als y-Vektor 0, 30 und 60, schafft die Funktion es nicht, an der Stelle 10 zu interpolieren, sondern meldet "Interpolationsfehler". Ich habe es jetzt so ähnlich gelöst (siehe unten), ist nur nicht sonderlich elegant: Mit x-Anzahl und y-Anzahl ermittel ich, wieviel Werte eingetragen sind, und setze dann Dimension auf das Minimum (Geht das eigentlich direkter? die IF-Abfrage ist doch sehr handgestrickt :-))
Viele Grüße,
Doro
Public 

Function LIP(xVector As Range, yVector As Range, xValue As Double)
Dimension = xVector.Cells.Count
xAnzahl = 1
yAnzahl = 1
Do While xVector.Cells(xAnzahl) <> ""
xAnzahl = xAnzahl + 1
Loop
xAnzahl = xAnzahl - 1
Do While yVector.Cells(yAnzahl) <> ""
yAnzahl = yAnzahl + 1
Loop
yAnzahl = yAnzahl - 1
If xAnzahl <= yAnzahl Then
Dimension = xAnzahl
Else
Dimension = yAnzahl
End If
If xValue < xVector.Cells(1).Value Or xValue > xVector.Cells(Dimension).Value Then
If xValue < xVector.Cells(1).Value Then
m = (yVector.Cells(2) - yVector.Cells(1)) / (xVector.Cells(2) - xVector.Cells(1))
n = yVector.Cells(2) - m * xVector.Cells(2)
Else
m = (yVector.Cells(Dimension) - yVector.Cells(Dimension - 1)) / (xVector.Cells(Dimension) - xVector.Cells(Dimension - 1))
n = yVector.Cells(Dimension) - m * xVector.Cells(Dimension)
End If
LIP = m * xValue + n
Else
For I = 2 To Dimension
If xValue <= xVector.Cells(I).Value Then Exit For
Next I
LIP = yVector.Cells(I - 1).Value _
+ (xValue - xVector.Cells(I - 1).Value) / (xVector.Cells(I).Value - xVector.Cells(I - 1).Value) _
* (yVector.Cells(I).Value - yVector.Cells(I - 1).Value)
End If
End Function

Anzeige
AW: Makro Lineare Interpolation (und Extrapolation
29.01.2007 11:40:12
fcs
Hallo Doro,
da hatte ich beim Testen scheinbar Wertepaare (Anzahl oder Werte) gewählt bei denen dieser Fehler nicht auftritt.
Folgende Korrektur sollte es jetzt bringen
Gruß
Franz

Function LIP(xVector As Range, yVector As Range, xValue As Double)
Dim Dimension As Long, MinDim As Long, MaxDim As Long
Dim I_oben As Long, I_unten As Long, I As Long
Dimension = xVector.Cells.Count
On Error GoTo Fehler
'1. X-Y-Wertepaar bestimmen, das verschieden ist von Leerstring
For I = 1 To Dimension
If xVector(I) <> "" And yVector(I) <> "" Then MinDim = I: Exit For
Next
'letztes X-Y-Wertepaar bestimmen, das verschieden ist von Leerstring
For I = Dimension To 1 Step -1
If xVector(I) <> "" And yVector(I) <> "" Then MaxDim = I: Exit For
Next
If xValue < xVector.Cells(MinDim).Value Or xValue > xVector.Cells(MaxDim).Value Then
'Extrapolation der Werte
If xValue < xVector.Cells(MinDim).Value Then
'Nächstes X-Y-Wertepaar mit Werten verschieden von Leerstring
For I = MinDim + 1 To Dimension
If xVector(I) <> "" And yVector(I) <> "" Then Exit For
Next
m = (yVector.Cells(I) - yVector.Cells(MinDim)) / (xVector.Cells(I) - xVector.Cells(MinDim))
n = yVector.Cells(I) - m * xVector.Cells(I)
Else
'Vorletztes X-Y-Wertepaar mit Werten verschieden von Leerstring
For I = MaxDim - 1 To MinDim Step -1
If xVector(I) <> "" And yVector(I) <> "" Then Exit For
Next
m = (yVector.Cells(MaxDim) - yVector.Cells(I)) / (xVector.Cells(MaxDim) - xVector.Cells(I))
n = yVector.Cells(MaxDim) - m * xVector.Cells(MaxDim)
End If
LIP = m * xValue + n
Else
'Interpolation der Werte
'X-Y-Wertepaar mit X-Wert >= gesuchten X-Wert
For I = MinDim + 1 To MaxDim
If xValue <= xVector.Cells(I).Value And yVector(I) <> "" Then I_oben = I: Exit For
Next I
'Vorheriges X-Y-Wertepaar mit Werten verschieden von Leerstring
For I = I_oben - 1 To MinDim Step -1 '###### Korrketur in dieser Zeile ####
If xVector(I) <> "" And yVector(I) <> "" Then I_unten = I: Exit For
Next
LIP = yVector.Cells(I_unten).Value _
+ (xValue - xVector.Cells(I_unten).Value) / _
(xVector.Cells(I_oben).Value - xVector.Cells(I_unten).Value) _
* (yVector.Cells(I_oben).Value - yVector.Cells(I_unten).Value)
End If
Exit Function
Fehler:
LIP = "Interpolationsfehler"
End Function

Anzeige
AW: Makro Lineare Interpolation (und Extrapolation
29.01.2007 14:24:46
Doro
Hallo Franz,
ja, so funktioniert es. Hat gegenüber meinem Makro den Vorteil, dass auch Leerzeilen enthalten sein können. Danke!!
Gruß,
Doro

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige