Microsoft Excel

Herbers Excel/VBA-Archiv

VBA: Schnittmengen-Problem

Betrifft: VBA: Schnittmengen-Problem von: ChristianM
Geschrieben am: 10.08.2014 12:10:59

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:


vielen Dank vorab
Grüße
ChristianM

  

Betrifft: Woran erkennt man in praxi, dass ein Element ... von: Luc:-?
Geschrieben am: 10.08.2014 13:56:37

…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 :-?


  

Betrifft: VBA: Differenzmengen-Problem von: ChristianM
Geschrieben am: 10.08.2014 14:56:19

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.


  

Betrifft: Ja, nur mit Schnittmengen wär's einfacher, ... von: Luc:-?
Geschrieben am: 10.08.2014 21:29:22

…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:

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 :-?


  

Betrifft: AW: Ja, nur mit Schnittmengen wär's einfacher, ... von: Christian
Geschrieben am: 11.08.2014 17:44:18

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


  

Betrifft: Ja, probier's aus, ... von: Luc:-?
Geschrieben am: 11.08.2014 20:30:21

…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 :-?


  

Betrifft: Teilmengen-Problem von: Erich G.
Geschrieben am: 12.08.2014 14:03:44

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


  

Betrifft: Teilmengen-Problem - neue Version von: Erich G.
Geschrieben am: 12.08.2014 19:41:19

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


  

Betrifft: Vielen Dank, Erich - Problem ist gelöst von: Christian
Geschrieben am: 14.08.2014 14:32:47

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