Thema Datum  Von Nutzer Rating
Antwort
05.04.2011 16:41:43 Jan
NotSolved
08.04.2011 11:14:30 Holger
NotSolved
10.04.2011 23:02:33 Jan
NotSolved
Blau Quick-Hull-Klasse in VBA übersetzen
21.04.2011 19:06:01 Holger
NotSolved
22.04.2011 10:24:55 Holger
NotSolved
28.04.2011 21:14:36 Jan
NotSolved
29.04.2011 00:56:30 Jan
NotSolved
30.04.2011 11:20:07 Gast10485
NotSolved
03.05.2011 17:22:18 Gast9766
Solved
10.10.2011 20:32:25 Gast93608
NotSolved
11.10.2011 11:04:15 Holger
NotSolved

Ansicht des Beitrags:
Von:
Holger
Datum:
21.04.2011 19:06:01
Views:
2162
Rating: Antwort:
  Ja
Thema:
Quick-Hull-Klasse in VBA übersetzen

Hallo Jan,

ich hatte leider dein Problem aus den Augen verloren. Man hat ja auch sonst so einiges zu tun. Nachstehendes Makro habe ich für Excel 2007 geschrieben. Nur dort konnte ich es testen, wobei ich keine Zeit habe, wirklich alle Aspekte auszuprobieren. Ich bitte um eine Rückmeldung, ob der Code den Anforderungen entspricht und ob Fehler aufgetreten sind. Ich bin sicher, dass noch Vereinfachungspotenzial besteht. Deinen Code habe ich nicht weiter angesehen.

Sub GrahamHüllKurve()
'Die x-Koordinaten der einzuhüllenden Punktmenge seien in Spalte A,
'die y-Koordinaten in Spalte B jeweils ab Zeile 2 eingetragen.
'Während der Berechnung werden die Punkte umsortiert. Punkte, die zur
'Enveloppe gehören, werden blau, andere rot eingefärbt.
'Es wird eine Grafik mit den Punkten mit gleichen Farben ausgegeben.
For Each s In ActiveSheet.Shapes ' ev. vorhandene Diagramme löschen
    s.Delete
Next
lz = Cells(Rows.Count, 1).End(xlUp).Row  'Anzahl der Punkte
If lz < 3 Then MsgBox "Zu wenig Punkte!": Exit Sub
Pi = 4 * Atn(1)
y_min = Cells(1, 2): m = 0
x_min = Application.WorksheetFunction.Min(ActiveSheet.Range(Cells(2, 1), Cells(lz, 1)))
y_min = Application.WorksheetFunction.Min(ActiveSheet.Range(Cells(2, 2), Cells(lz, 2)))
For i = 2 To lz
    Cells(i, 3) = Cells(i, 1) - x_min
    Cells(i, 4) = Cells(i, 2) - y_min
    'alle Winkel nach Konstruktion < Pi
    If Cells(i, 3) = 0 Then
        Cells(i, 5) = Sgn(Cells(i, 4)) * Pi / 2
    Else
        Cells(i, 5) = Atn(Cells(i, 4) / Cells(i, 3))
    End If
    If Cells(i, 3) < 0 Then Cells(i, 5) = Cells(i, 5) + Pi
Next i
With ActiveSheet.Sort 'nach Winkel und y reduziert
    .SortFields.Clear
    .SortFields.Add Key:=Range(Cells(2, 5), Cells(lz, 5)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range(Cells(2, 4), Cells(lz, 4)), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SetRange Range(Cells(2, 1), Cells(lz, 5))
    .Header = xlNo
    .Apply
End With
a = lz + 1
If lz > 2 Then
    For i = 3 To lz 'gleiche Winkel bestimmen und aussortieren
        If Cells(i - 1, 5) = Cells(i, 5) Then
            Cells(a, 1) = Cells(i, 1)
            Cells(a, 2) = Cells(i, 2)
            For j = 1 To 6: Cells(i, j) = "": Next j
            a = a + 1
        End If
    Next i
End If
For i = a - 1 To 2 Step -1
    If Cells(i, 1) = "" Then Rows(i).Delete
Next i
Do 'Algorithmus anwenden
    w = 0
    lz1 = Cells(Rows.Count, 3).End(xlUp).Row
    a = lz + 1
    For i = 2 To lz1 - 2
        If (Cells(i + 1, 3) - Cells(i, 3)) * (Cells(i + 2, 4) - Cells(i, 4)) - _
            (Cells(i + 2, 3) - Cells(i, 3)) * (Cells(i + 1, 4) - Cells(i, 4)) <= 0 Then
            Cells(a, 1) = Cells(i + 1, 1)
            Cells(a, 2) = Cells(i + 1, 2)
            For j = 1 To 6: Cells(i + 1, j) = "": Next j
            a = a + 1
            w = 1
            Exit For
        End If
    Next i
    If w = 1 Then
        For i = a - 1 To 2 Step -1
            If Cells(i, 1) = "" Then Rows(i).Delete
        Next i
    End If
Loop Until w = 0
lz1 = Cells(Rows.Count, 3).End(xlUp).Row 'Chart zeichnen
ActiveSheet.Shapes.AddChart(xlXYScatter, 350, 10, 500, 350).Select
With ActiveChart
    .HasTitle = True
    .ChartTitle.text = "Konvexe Hülle einer Punktmenge"
    .SeriesCollection.NewSeries
    With .SeriesCollection(1)
        .XValues = Range(Cells(2, 1), Cells(lz1, 1))
        .Values = Range(Cells(2, 2), Cells(lz1, 2))
        .Interior.Color = RGB(0, 255, 0)
        .Name = "Enveloppe"
    End With
    Range(Cells(2, 1), Cells(lz1, 2)).Font.Color = vbBlue
    If lz1 < lz Then
        .SeriesCollection.NewSeries
        With .SeriesCollection(2)
            .XValues = Range(Cells(lz1 + 1, 1), Cells(lz, 1))
            .Values = Range(Cells(lz1, 2), Cells(lz, 2))
            .Interior.Color = RGB(255, 0, 0)
            .Name = "Sonstige Punkte"
            .MarkerStyle = 2
            .MarkerSize = 5
        End With
        Range(Cells(lz1 + 1, 1), Cells(lz, 2)).Font.Color = vbRed
    End If
End With
ActiveSheet.Columns("c:e").Delete
End Sub

Gruß

Holger


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
05.04.2011 16:41:43 Jan
NotSolved
08.04.2011 11:14:30 Holger
NotSolved
10.04.2011 23:02:33 Jan
NotSolved
Blau Quick-Hull-Klasse in VBA übersetzen
21.04.2011 19:06:01 Holger
NotSolved
22.04.2011 10:24:55 Holger
NotSolved
28.04.2011 21:14:36 Jan
NotSolved
29.04.2011 00:56:30 Jan
NotSolved
30.04.2011 11:20:07 Gast10485
NotSolved
03.05.2011 17:22:18 Gast9766
Solved
10.10.2011 20:32:25 Gast93608
NotSolved
11.10.2011 11:04:15 Holger
NotSolved