Microsoft Excel

Herbers Excel/VBA-Archiv

Algorithmus

Betrifft: Algorithmus von: Engin
Geschrieben am: 08.08.2008 13:56:28

Hallo Leute,

wer kann mir bei diesem Algorithmus helfen. Ich möchte die Abstände von jeden Gelben Punkt zu der Grünen Gerade berechnen, dazu muss ich erstmal auf der grünen Gerade zwichen zwei punkte eine Gerade berechen um den drüberliegenden Punkt zu berechnen. Das Programm soll mir jetzt den Abstand zu der richtigen Gerade berechen also er muss erst gucken welche Gerade im Werteberich von den gelben Punkt liegt. Kurz gefasst es klappt bei mir nur die Doppelten(zwei punkte zu einer Gerade) macht er nicht. schaut euch am besten den Code und das bild an.

https://www.herber.de/bbs/user/54445.xls


Danke

  

Betrifft: AW: Algorithmus von: Daniel
Geschrieben am: 08.08.2008 16:38:33

Hi

wo ist jetzt dein Problem:

beim ermitteln der beiden Geradengeleichungen für für die gründe Gerade?
dabei hilft dir im Diagramm der Kontextmenüpunkt TRENDLINIE EINFÜGEN (dort kannst du Steigung und Achsenabschnitt dann abschreiben) bzw als Excefunktion die statistische Funktion RGP (hierzu bitte die Excelhilfe lesen)

bei der Abstandberechnung?

dazu musst du den X-Wert der Messung in die Geradengleichung der berechneten Geraden einsetzen und das Ergebnis vom Y-Wert der Messung abziehen.
wenn du 2 Geradengleichungen einer Abschnittsweise definieren funktion hast, dann musst du das über die WENN-Funktion teilen:
mal so im Prinzip:

= Wenn(Xm < 0,01; Ym - F1(Xm); Ym - F2(Xm))

Xm und Ym sind die x- und y- Koordinaten eines Messergebnisses
F1 ist die Geradenfunkion im Abschnitt <0,01 und F2 ist die Geradenfunktion im Abschnitt > 0,01

Gruß, Daniel


  

Betrifft: AW: Algorithmus von: ChristianM
Geschrieben am: 08.08.2008 16:48:39

Hallo Engin,
so z.B.
Gruß
Christian

Option Explicit

Sub GetDistance()
   Dim dblExpX(13) As Double, dblExpY(13) As Double
   Dim dblCalX(14) As Double, dblCalY(14) As Double
   Dim dblRes(14) As Double
   Dim i As Long, k As Long
   
   With Sheets("Tabelle1")
      For i = 3 To UBound(dblExpX) + 3
         dblExpX(i - 3) = .Cells(i, 1)
         dblExpY(i - 3) = .Cells(i, 2)
      Next
      For i = 3 To UBound(dblCalX) + 3
         dblCalX(i - 3) = .Cells(i, 6)
         dblCalY(i - 3) = .Cells(i, 7)
      Next

      For i = 0 To UBound(dblExpX)
         Do Until dblCalX(k) >= dblExpX(i) Or k = UBound(dblCalX)
            k = k + 1
         Loop
         If dblExpX(i) <= dblCalX(UBound(dblCalX)) Then
            dblRes(i) = dblCalY(k - 1) - dblExpY(i) + (dblCalY(k) - dblCalY(k - 1)) / _
               (dblCalX(k) - dblCalX(k - 1)) * (dblExpX(i) - dblCalX(k - 1))
         End If
      Next
      .Range(.Cells(3, 4), .Cells(17, 4)).Value = Application.Transpose(dblRes)
   End With
End Sub