Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1372to1376
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA: Schnittmengen-Problem

VBA: Schnittmengen-Problem
10.08.2014 12:10:59
ChristianM
Hallo bestes Forum,
bei einem Schnittmengen- bzw. Teilmengen-Problem in VBA komme ich nicht weiter und hoffe auf eure Hilfe.
Bspiel-Datei:
https://www.herber.de/bbs/user/91999.xlsm
Einfaches Beispiel:
Gegeben:
- in einem Bereich (B_001) sind z.B. 5 Elemente (E_001 bis E_005) enthalten.
- ein zweiter Bereich (B_002) enthält die Elemente E_004 und E_005.
gesuchtes Ergebnis:
- die Elemente E_004 und E_005 gehören nur zu Bereich B_002
- die Elemente E_001, E002 und E_003 gehören zu Bereich B_001
Begründung:
- Bereich B_002 enthält ausschließlich die Elemente E_004 und E_005. Daher sind diese dem Bereich B_002 und nicht B_001 zuzuordnen.
Das ganze kann sehr komplex werden, denn zum einen ist es nicht nur auf 2 Bereiche begrenzt und zum anderen kann es Bereiche geben, die sich vollständig (Teilmenge) oder teilweise (Schnittmenge) überschneiden. Ebenso kann es Bereiche geben, die keine Elemente haben und auch "freie" Elemente, die keinem Bereich zhugeordnet sind.
Dieses und weitere Beispiel als Grafik dargestellt:
Userbild
vielen Dank vorab
Grüße
ChristianM

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Woran erkennt man in praxi, dass ein Element ...
10.08.2014 13:56:37
Luc:-?
…mehreren Bereichen zugeordnet ist, Christian,
denn du scheinst ja erst eine Zuordnung treffen zu wollen und die Farbe wird's ja wohl nicht sein und die räumliche Anordnung sicher auch nicht. Das Ganze ist doch recht schleierhaft, wenn man nicht weiß, wie die „Bereiche“ gebildet wdn, oder stehen die Gruppen und ihre Elemente von vornherein fest? Hinzu kommt, dass es sich jeder Logik zu entziehen scheint, dass in Bsp5 die Elemente 4/5 nicht „zugewiesen“ wdn können. Nach der klassischen SchnittmengenBildung wäre das Ergebnis von schwarz|rot nämlich {4.5} und das von schwarz|grün {1}. So, wie du rechnest, scheint es sich zumindest teilweise um Differenzmengen zu handeln: schwarz-rot-grün⇒{2.3}, rot-schwarz⇒{6.7}.
Später (bin jetzt auf Linux) werde ich deine Bsp-Konstellationen mal mit meinen UDFs nachrechnen. Mal sehen, was dabei rauskommt… ;-)
Gruß + schöSo, Luc :-?

Anzeige
VBA: Differenzmengen-Problem
10.08.2014 14:56:19
ChristianM
Hallo Luc,
in der in meiner Frage angehängten Excel-Datei sind die ursprünglichen Zuordungen aufgelistet.
Also ja, die Bereiche und ihre Elemente stehen von vornherein fest.
Im Tabellenblatt "Bereich-Element" sieht man für Bsp-1, dass dem Bereich-1 die Elemente 1 bis 5 zugeordnet sind und eben auch dem Bereich-2 die Elemente 4 und 5.
Zusätzlich gibt es dort die Tabelle "Element-Bereich". Das ist im Grunde die gleiche Tabelle nur mit umgekehrter Zuordnung.
Die unterschiedichen Auflistungen zeigen in Tab. "Bereich-Element" eben auch Bereiche, denen kein Element zugeordnet ist und in Tab. "Element-Bereich" werden auch Elemente aufgelistet, die zu keinem Bereich gehören.
Ziel ist es, jedes Element eindeutig nur genau einem Bereich zuzuordnen.
In Bsp-5 ist das für die Elemente 4 und 5 aus meiner Sicht nicht möglich.
Deine Bezeichnung "Differenzmengen" ist zur Beschreibung des Problems bestimmt geeigneter, aber Mengenleere ist bei mit schon gute 30 Jahre her, da sind mir die Begriffe nicht mehr so geläufig.
Die grafische Darstellung mit Farben dient nur der Veranschaulichung des Problems, die Daten hierzu stehen in der Excel-Datei.
Vielen Dank für deine Gedanken
Grüße
Christian
PS: Das ganze hat einen realen Hintergrund. Die Basis-Daten kommen aus dwg-Dateien. Diese Daten müssen entsprechend analysiert werden. Innerhalb dieser Analyse müssen per VBA einzelne Positionen (Elemente) bestimmten Bereichen nach obigem Schema zugeordnet werden.

Anzeige
Ja, nur mit Schnittmengen wär's einfacher, ...
10.08.2014 21:29:22
Luc:-?
…Christian,
den bei Differenzmengen hast du nicht nur das eher nachgeordnete Problem der leeren Bereiche und verwaisten Elemente, sondern hptsächlich das einer eindeutigen und auf alle Fälle anwendbaren Bildungsregel! Um mal zu verdeutlichen, was ich meine, habe ich das mal anhand von Bsp7 untersucht, was das folgd Bild zeigt:
Userbild
Die angezeigten Fmln sind hier nur reine Info, denn die kannst du nicht verwenden (UDFs!); sie zeigen aber für Schnitt- (ISet) und DifferenzMengen (DSet) den Bildungsweg (da diese UDFs dem Vgl von Aufzählungen [ListenText] dienen, mussten die Ausgangsdaten hier erst in diese Form gebracht wdn).
Kannst du eine solche allgemeingültige Regel formulieren? Anderenfalls müsste ich mal sehen, ob sie aus deinen Bspp und Erwartun­gen ableitbar ist. Das Feststellen, zu welcher Gruppe ein Element gehört, ist dabei ein sekundäres Problem. Das kann man mit Schleife über alle Elemente und WorksheetFunction.Match bzw Range(…).Find…FindNext lösen.
Gruß, Luc :-?

Anzeige
AW: Ja, nur mit Schnittmengen wär's einfacher, ...
11.08.2014 17:44:18
Christian
hallo Luc,
vielen Dank für deinen Vorschlag. Ich würde das gerne direkt in VBA erschlagen, ohne in den Tabellen noch Zwischenrechnungen auszuführen (wobei das sicher auch mit deinem Ansatz funktionieren würde...).
Ich hab gestern noch lange gegrübelt und glaube, ich hab einen Weg gefunden.
Die Idee ist folgende:
- lese die Daten aus Tab. "Bereich-Element" und Tab. "Element-Bereich" in zwei Arrays.
- erzeuge davon 2 Dictionaries mit "alle Elemente pro Bereich" und "alle Bereiche pro Element"
- Durchlaufe das Array aus Tab. "Bereich-Element"
-- wenn einem Element nur ein Bereich zugeordnet ist,
--- dann schreibe den Datensatz direkt in das Ergebnis-Array vntResult.
-- sonst hole die Elemente der weiteren Bereiche aus dem Dictionary "alle Elemente pro Bereich"
-- und prüfe für jedes Element, ob es auch in dem vorherigen Bereich vorhanden ist.
-- Wenn alle Elemente des weiteren Bereichs auch im vorherigen Bereich vorkommen, dann gehören die Elemente zum weiteren Bereich und schreibe diese Zuord. nach vntResult.
Auf Basis von Bsp7 müsste also jetzt in vntResult stehen:
B_001---E_001---eindeutig
B_001---E_002---eindeutig
B_001---E_003---eindeutig
B_001---E_004---eindeutig
B_002---E_007---eindeutig
B_004---E_008---Zuord. nach B_004
B_003---E_009---eindeutig
Anschließend:
- prüfen, ob eine Element-ID die Länge 0 hat, damit wird der Bereich B_005 erschlagen.
- alle weiteren Elemente aus Tab. "Bereich-Element" (also E_005 und E_006) können somit nicht eindeutig zugeordnet werden und schreibe das auch nach vntResult.
- zuletzt noch Elemente ohne Bereich aus Tab. "Element-Bereich" dranhängen.
Wenn ich da nicht noch einen dicken Denkfehler drin habe, müsste das laufen... Ich schau mal, ob ich das umsetzten kann.
Nochmals Danke für deine Vorschläge und Antworten. Auch wenn ich jetzt einen etwas anderen Weg einschlage, hat mir das weiter geholfen.
Grüße
Christian

Anzeige
Ja, probier's aus, ...
11.08.2014 20:30:21
Luc:-?
…Christian,
meine Darstellung sollte ja auch nur das Problem veranschaulichen, weshalb ich das benutzt habe, was ich bereits hatte. Ohne feste, stets gleiche Regel, wären die Ergebnisse der Differenzmengen-Bildung beinahe zufällig. Wenn das, was du vorhast, quasi eine solche Regel darstellt, wird's schon klappen. ;-)
Viel Erfolg! Gruß, Luc :-?

Teilmengen-Problem
12.08.2014 14:03:44
Erich
Hi Christian,
probier das doch mal aus:

Option Explicit
Sub aZuor()
Dim lngS As Long, lngA As Long, arQ, zz As Long
Dim oBNr As Object, iBNr As Long, oENr As Object, iENr As Long
Dim oBer As Object, arE, arBK, arEK, ee As Long, ff As Long
Dim arR(), ss As Long, strB As String, arErg()
Set oBNr = CreateObject("Scripting.Dictionary")
Set oENr = CreateObject("Scripting.Dictionary")
Set oBer = CreateObject("Scripting.Dictionary")
With Sheets("Element-Bereich")
For lngS = 2 To 26 Step 4 '2 To 26 Step 4       ' Schleife über Beispiele
lngA = Application.Max(.Cells(18, lngS).End(xlUp).Row, _
.Cells(18, lngS + 1).End(xlUp).Row) - 2
arQ = .Cells(3, lngS).Resize(lngA, 2)                 ' Quelldaten
For zz = 1 To lngA
If arQ(zz, 2)  "" Then
If Not oBNr.Exists(arQ(zz, 2)) Then
iBNr = iBNr + 1:    oBNr(arQ(zz, 2)) = iBNr  ' Bereiche zählen
End If
If oBer.Exists(arQ(zz, 2)) Then        ' Elemente pro Bereich erfassen
arE = oBer(arQ(zz, 2))
ReDim Preserve arE(1 To UBound(arE) + 1)
Else
ReDim arE(1 To 1)
arE(1) = arQ(zz, 1)
End If
arE(UBound(arE)) = arQ(zz, 1)
oBer(arQ(zz, 2)) = arE
End If
Next zz
For zz = 1 To lngA                           ' Elemente zählen
If Not oENr.Exists(arQ(zz, 1)) Then
iENr = iENr + 1:    oENr(arQ(zz, 1)) = iENr
End If
Next zz
ReDim arR(iENr, iBNr)                        ' Array dimensionieren
arBK = oBNr.Keys
arEK = oENr.Keys
For zz = 1 To iBNr
arR(0, zz) = arBK(zz - 1)                 ' Kopf: Bereiche
Next zz
For zz = 1 To iENr
arR(zz, 0) = arEK(zz - 1)                 ' 1. Spalte: Elemente
Next zz
For zz = 1 To lngA
If arQ(zz, 1)  "" And arQ(zz, 2)  "" Then  ' Bereiche pro Element
arR(oENr(arQ(zz, 1)), oBNr(arQ(zz, 2))) = 1
End If
Next zz
'         .Cells(33, lngS).Resize(UBound(arR) + 1, UBound(arR, 2) + 1) = arR
For ee = 1 To iBNr                           ' Teilmengen finden
For ff = 1 To iBNr
If UBound(oBer(arR(0, ff))) > UBound(oBer(arR(0, ee))) Then
If TeilM(oBer(arR(0, ee)), oBer(arR(0, ff))) Then
For ss = 1 To iENr               ' Elemente in Obermengen löschen
If arR(ss, oBNr(arR(0, ee))) = 1 And _
arR(ss, oBNr(arR(0, ff))) = 1 Then
arR(ss, oBNr(arR(0, ff))) = ""
End If
Next ss
End If
End If
Next ff
Next ee
'         .Cells(43, lngS).Resize(UBound(arR) + 1, UBound(arR, 2) + 1) = arR
ReDim arErg(1 To iENr, 1 To 2)                              ' Ausgaben
For ee = 1 To iENr
arErg(ee, 1) = arR(ee, 0)                                ' Element
ss = 0
For ff = 1 To iBNr
If arR(ee, ff)  "" Then
ss = ss + 1                                        ' Anz. Bereiche
strB = arR(0, ff)
End If
Next ff
Select Case ss
Case 0: arErg(ee, 2) = "ohne Bereich"
Case 1: arErg(ee, 2) = "zu " & strB
Case Else: arErg(ee, 2) = "mehrere Bereiche"
End Select
Next ee
.Cells(53, lngS).Resize(UBound(arErg), UBound(arErg, 2)) = arErg
iBNr = 0
iENr = 0
oBer.RemoveAll
oBNr.RemoveAll
oENr.RemoveAll
Next lngS
End With
End Sub
Function TeilM(arA, arB) As Boolean
Dim ii As Long, jj As Long
For ii = LBound(arA) To UBound(arA)
For jj = LBound(arB) To UBound(arB)
If arA(ii) = arB(jj) Then Exit For
Next jj
If jj > UBound(arB) Then Exit Function ' not found
Next ii
TeilM = True
End Function
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

Anzeige
Teilmengen-Problem - neue Version
12.08.2014 19:41:19
Erich
Hi Christian,
hier eine neue Version, mit weiteren Ausgaben:

Sub TeilmengenZuordn()
Dim lngS As Long, lngA As Long, arQ, zz As Long
Dim oBNr As Object, iBNr As Long, oENr As Object, iENr As Long
Dim oBer As Object, arE, arBK, arEK, ee As Long, ff As Long, iOhne As Long
Dim arR(), ss As Long, strB As String, arErg()
Set oBNr = CreateObject("Scripting.Dictionary")
Set oENr = CreateObject("Scripting.Dictionary")
Set oBer = CreateObject("Scripting.Dictionary")
With Sheets("Element-Bereich")
For lngS = 2 To 26 Step 4 '2 To 26 Step 4       ' Schleife über Beispiele
lngA = Application.Max(.Cells(18, lngS).End(xlUp).Row, _
.Cells(18, lngS + 1).End(xlUp).Row) - 2
arQ = .Cells(3, lngS).Resize(lngA, 2)                 ' Quelldaten
For zz = 1 To lngA
If arQ(zz, 1) = "" Then
iOhne = iOhne + 1
arQ(zz, 1) = ""
End If
If arQ(zz, 2) = "" Then arQ(zz, 2) = ""
If Not oBNr.Exists(arQ(zz, 2)) Then
iBNr = iBNr + 1:    oBNr(arQ(zz, 2)) = iBNr  ' Bereiche zählen
End If
If oBer.Exists(arQ(zz, 2)) Then        ' Elemente pro Bereich erfassen
arE = oBer(arQ(zz, 2))
ReDim Preserve arE(1 To UBound(arE) + 1)
Else
ReDim arE(1 To 1)
arE(1) = arQ(zz, 1)
End If
arE(UBound(arE)) = arQ(zz, 1)
oBer(arQ(zz, 2)) = arE
'           End If
Next zz
For zz = 1 To lngA                           ' Elemente zählen
If Not oENr.Exists(arQ(zz, 1)) Then
iENr = iENr + 1:    oENr(arQ(zz, 1)) = iENr
End If
Next zz
ReDim arR(iENr, iBNr)                        ' Array dimensionieren
arBK = oBNr.Keys
arEK = oENr.Keys
For zz = 1 To iBNr
arR(0, zz) = arBK(zz - 1)                 ' Kopf: Bereiche
Next zz
For zz = 1 To iENr
arR(zz, 0) = arEK(zz - 1)                 ' 1. Spalte: Elemente
Next zz
For zz = 1 To lngA
If arQ(zz, 1)  "" And arQ(zz, 2)  "" Then  ' Bereiche pro Element
arR(oENr(arQ(zz, 1)), oBNr(arQ(zz, 2))) = 1
End If
Next zz
.Cells(20, lngS).Resize(100, UBound(arR, 2) + 1).ClearContents
.Cells(20, lngS).Resize(UBound(arR) + 1, UBound(arR, 2) + 1) = arR
For ee = 1 To iBNr                           ' Teilmengen finden
For ff = 1 To iBNr
If UBound(oBer(arR(0, ff))) > UBound(oBer(arR(0, ee))) Then
If TeilM(oBer(arR(0, ee)), oBer(arR(0, ff))) Then
For ss = 1 To iENr               ' Elemente in Obermengen löschen
If arR(ss, oBNr(arR(0, ee))) = 1 And _
arR(ss, oBNr(arR(0, ff))) = 1 Then
arR(ss, oBNr(arR(0, ff))) = ""
End If
Next ss
End If
End If
Next ff
Next ee
.Cells(20 + UBound(arR) + 3, lngS).Resize(UBound(arR) + 1, UBound(arR, 2) + 1) = arR
oBer.RemoveAll
iOhne = 0
For ff = 1 To iBNr
For zz = 1 To iENr
If arR(zz, ff) = 1 Then Exit For
Next zz
If zz > iENr Then
iOhne = iOhne + 1
oBer(iOhne) = arR(0, ff)
End If
Next ff
ReDim arErg(1 To iENr + iOhne, 1 To 2)                            ' Ausgaben
For ee = 1 To iENr
arErg(ee, 1) = arR(ee, 0)                                ' Element
ss = 0
For ff = 1 To iBNr
If arR(ee, ff)  "" Then
ss = ss + 1                                        ' Anz. Bereiche
strB = arR(0, ff)
End If
Next ff
Select Case ss
'               Case 0: arErg(ee, 2) = "ohne Bereich"
Case 1: arErg(ee, 2) = strB
Case Else: arErg(ee, 2) = "    # Viele #"
End Select
Next ee
For ee = 1 To iOhne
arErg(iENr + ee, 1) = ">"
arErg(iENr + ee, 2) = oBer(ee)
Next ee
.Cells(20 + 2 * UBound(arR) + 6, lngS).Resize(UBound(arErg), UBound(arErg, 2)) = arErg
iBNr = 0
iENr = 0
iOhne = 0
oBNr.RemoveAll
oENr.RemoveAll
Next lngS
End With
End Sub
Und hier die SpielMappe: https://www.herber.de/bbs/user/92057.xlsm
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

Anzeige
Vielen Dank, Erich - Problem ist gelöst
14.08.2014 14:32:47
Christian
hallo Erich,
deine Antworten hab ich eben erst gesehen und deinen Code getestet. Das sieht sehr gut aus.
Vielen herzlichen Dank.
In der Zwischenzeit hatte ich meinen Ansatz weiter verfolgt und komme bei den Beispielen zu dem gleichen Ergebnis wie du.
Wenn man aber in einem weiteren Bsp-8 ausgehend von Bsp-7 den orangen Bereich (B_005) um die Elemente 5 und 6 legt, dann müsste 5 und 6 zu orange gehören. In deinem Code wird E_005 dabei nicht eindeutig dem Bereich B_005 zugeordnet.
Wie Luc schon sagte, das eigentliche Problem ist das Aufstellen einer Regel. Dies ist mir mittlerweile gelungen und ist in meinem Code auch entsprechend umgesetzt. Aber, dein Ansatz ist prima und für das Fein-Tuning kann ich davon sicher einige Punkte übernehmen.
Viele Grüße
Christian
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige