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