Hallo Leon,
die Nullstellen werden ins Array n(i) und die Extrema ins Array ex(i,j) geschrieben, wobei ex(0,i) für das Argument und ex(1,i) für deie Werte der Extrema verwendet wird. Last_n ist zu Beginn 0 (genauer gesagt leer) und wird später immer, wenn die Werte einen Vorzeichenwechsel haben oder verschwinden, mit der Zeilenzahl i der letzten Nullstelle gefüllt. frq() sammelt die Abstände der Nullstellen und frq1() die der Extrema. Beides sind Maße für die Länge der Periode, so dass ich beide für deren Bestimmung heranziehe. Für die Wertetabelle habe ich einen einfachen Vorschlag eingefügt.
Sub Amplitude_Periodenlänge()
a = -1
ReDim n(0), ex(1, 0)
Sp1 = 1 'Spalte mit den Argumenten (Zeitpunkten ???)
Sp2 = 2 'Spalte mit den Sinus-Werten
Sp3=4'Spalte für die Nullstellel
Sp4=5'Spalte für die Extremaargumente
sp5=6'Spalte für Extremawerte
Null_min = Val(InputBox("Minimalabstand (Zeilenanzahl) der Nullstellen angeben", ,"3"))
For i = 2 To Cells(Rows.Count, Sp2).End(xlUp).Row
If (Sgn(Cells(i - 1, Sp2)) <> Sgn(Cells(i, Sp2))) Or (Cells(i - 1, Sp2) = 0) Then 'potenzielle Nullstelle
If i - Last_n > Null_min Then 'verhindert Auswertung von Schwankungen um 0
a = a + 1
ReDim Preserve n(a), ex(1, a)
n(a) = Cells(i - 1, Sp1) 'Argument der Nullstelle
cells(a+1,sp3)=n(a)
ex(0, a) = X 'Argument des Extremums
cells(a+1,sp4)=x
ex(1, a) = m 'Wert des Extremums
cells(a+1,sp5)=m
m = 0 'Ausgangswert Max/Min
Last_n = i
End If
End If
If Cells(i, Sp2) > 0 Then 'Maximum suchen
If Cells(i, Sp2) > m Then m = Cells(i, Sp2): X = Cells(i, Sp1)
Else 'Minimum suchen
If Cells(i, Sp2) Sgn(Cells(i, Sp2))) Or (Cells(i - 1, Sp2) = 0) Then 'potenzielle Nullstelle
If i - Last_n > Null_min Then 'verhindert Auswertung von Schwankungen um 0
a = a + 1
ReDim Preserve n(a), ex(1, a)
n(a) = Cells(i - 1, Sp1) 'Argument der Nullstelle
ex(0, a) = X 'Argument des Extremums
ex(1, a) = m 'Wert des Extremums
m = 0 'Ausgangswert Max/Min
Last_n = i
End If
End If
If Cells(i, Sp2) > 0 Then 'Maximum suchen
If Cells(i, Sp2) > m Then m = Cells(i, Sp2): X = Cells(i, Sp1)
Else 'Minimum suchen
If Cells(i, Sp2) < m Then m = Cells(i, Sp2): X = Cells(i, Sp1)
End If
Next i
ReDim amp(a), frq(a), frq1(a)
For i = 0 To a - 1
amp(i) = Abs(ex(1, i) - ex(1, i + 1))
frq1(i) = 2*Abs(ex(0, i) - ex(0, i + 1))
frq(i) = 2*Abs(n(i) - n(i + 1))
Next i
With WorksheetFunction
MsgBox ("Amplitude: " + CStr(.Average(amp())) + " ± " + CStr(.StDevP(amp())) + vbCrLf + _
"Periodenlänge: " + CStr(.Average(frq(), frq1())) + " ± " + CStr(.StDevP(frq(), frq1())))
End With
End Sub
Gruß
Holger
Leon schrieb am 14.07.2009 14:09:57:
Hi,
ich bin auf der Suche nach einem Makro, mit dem ich aus einer sinusförmigen Funktion die Amplituden und die Frequenz auslesen kann. Ich bin hier im Forum auch schon fündig geworden (Beitrag vom 17.06.2009).
Wenn ich das richtig verstehe, werden dort mit der Sgn-Funktion lokale Maxima/Minima bestimmt. Da ich mit realen Messwerten arbeite, entspricht das nicht ganz meinen Anforderungen, da diese um den idealen Verlauf schwanken und ich somit permanent lokale Extrema produziere.
Beim Versuch das Problem mit Applikation.WorksheetFunktion.Max/Min zu lösen, erhalte ich immer nur ein Maximum je Messreihe. Ich benötige aber das Maximum/Minimum je halbe Periode.
Ich sehe 3 Möglichkeiten das Problem zu lösen:
1.Eine Funktion die Amplitude/Frequenz aus Sinusfunktionen extrahieren kann (ist mir in Excel nicht bekannt)
2.Bestimmung des globalen Maximums/Minimums zwischen 2 Nullstellen.
3.Vergrößerung der Umgebung um den Wert
Leider habe ich keine Ahnung wie, ihr vielleicht?
Danke
Leon
|