Punkte in einer Y-X-Diagrammwolke ergänzen

Hi Miteinander!
Ich habe ...

...eine recht große x-Y-Punktwolke (ca. 230.000 Punkte)
Sie ist in einem Dictionary-Object ("DatenDict") hinterlegt
DictDaten("1|1")="Text"

...eine Zuordnungstabelle, die den Koordinaten einen Wert zuweist (ca 8.200 Zuordnungen)
Sie ist in einem DictionaryObject ("ZuordDict") hinterlegt
ZuordDict("1|1")=5

Nun sollen für alle Koordinaten im DatenDict Werte aus der ZuordDict zugewiesen werden.
Die direkte Zuweisung von ZuordDict-Werten zu DatenDict.Keys ist ja einfach - mein Problem ist, dass ich JEDEN DatenDict.Key mit Werten versorgen muss...
Mein Ansatz bisher:
für jedes Element der DatenDict.Keys alle ZuordDict.Keys durchgehen, Entfernung der Koordinaten berechnen, MinEntfernung merken und dann den Wert der Koordinate mit der kleinsten Entfernung in DatenDict übernehmen.
Die Subs zum Füllen der Dicts und die Subs zum Auswerten des DatenDict hinterher benötigen 4-20 sec. Damit kann ich leben.
Nur der Ansatz für die Zuordnungen dauert bei mir ca. 4,5 Stunden!!!!
(ist ja auch irgendwie logisch, wenn er 1.886.000.000 mal verschiedene Dicts auslesen, Berechnungen anstellen und Werte schreiben muss...)
Hat jemand eine Idee, wie ich diese Zuordnungen schneller hinbekomme?
Danke!
MFG
Daniel
(Hier mal ein verkleinertes Beispiel)
https://www.herber.de/bbs/user/90537.xls

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Daniel,
einen gewissen Zeitgewinn solltest du erreichen, wenn du Zuordnen wie folgt anpasst.
Dann müssen die Split-Anweisungen für ZuordDict nur einmal ausgeführt werden. In der Schleife über die DatenDict wird dann auf die Daten des angelegten Arrays zugegriffen.
Zeitgewinn: ?
Im Ausgabe-Makro lohnt sich dies für die DatenDict-Elemente wahrscheinlich nicht, da nur 2 Durchläufe erfolgen.
Gruß
Franz

Sub Zuordnen()
Dim DatElement As Variant
Dim ZuordElement As Variant
Dim MinEntf As Double, Entf As Double, EntfKey As String
Dim arrZuord() As Double, lngJ As Long
ReDim arrZuord(1 To ZuordDict.Count, 1 To 2)
lngJ = 0
For Each ZuordElement In ZuordDict
lngJ = lngJ + 1
arrZuord(lngJ, 1) = Split(ZuordElement, "|")(0)
arrZuord(lngJ, 2) = Split(ZuordElement, "|")(1)
Next
'hier soll irgendwie die Zuordnung hin
For Each DatElement In DatenDict
MinEntf = 1000000
lngJ = 0
For Each ZuordElement In ZuordDict
'Entf=Wurzel aus((X2-X1)²+(Y2-Y1)²)
lngJ = lngJ + 1
Entf = ((Split(DatElement, "|")(0) - arrZuord(lngJ, 1)) ^ 2 + _
(Split(DatElement, "|")(1) - arrZuord(lngJ, 2)) ^ 2) ^ 0.5
MinEntf = WorksheetFunction.Min(MinEntf, Entf)
If MinEntf = Entf Then EntfKey = ZuordElement
Next
DatenDict(DatElement) = ZuordDict(EntfKey)
Next
Erase arrZuord
End Sub

Beliebteste Forumthreads (12 Monate)

Punkte in einer Y-X-Diagrammwolke ergänzen

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Punkte in einer Y-X-Diagrammwolke ergänzen

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread