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
|