Listen mit Listen vergleichen

Hallo zusammen,
folgende Anfrage habe ich bereits in einem anderen Forum gepostet, dort aber leider keine Antwort bekommen. Deshalb versuche ich es nun hier, in der Hoffnung, dass mir hier jemand helfen kann.
Im Anhang ( https://www.herber.de/bbs/user/109021.xlsx ) findet ihr die Excel Datei, zu der ich Hilfe benötige.
Auf Tabellenblatt 1 "entry mask" möchte ich 14 (C4:C17) bzw. 7 (G4:G10) Werte auswählen und diese mit möglichen Szenarien aus Tabellenblatt 5 vergleichen.
Sollte eine übereinstimmendes Szenario gefunden werden, sollen auf Tabellenblatt 1 "entry mask" die reaction automatisch ausgefüllt werden. Diese müssen aus dem übereinstimmenden Szenario geladen werden.
Die Auswahlmöglichkeiten für die "initial states", "actions" und "reactions" sind auf den Tabellenblättern 2-4 aufgelistet.
Vermutlich gibt ist der Aufbau der Datei nicht optimal.
Kann mir jemand von Euch sagen, wie der Vergleich der grauen Listen und das automatische Ausfüllen der orange gefärbten Reaktionen am besten umgesetzt werden kann?
Danke im Voraus für jede konstruktive Antwort.
Gruß
Thomas

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Thomas,
in "entry mask":

Option Explicit
Dim initOk&, oC, r1$, r2$, r3$, zOff
Private Sub Worksheet_Change(ByVal Target As Range)
Dim gefunden&, i&, z&, s&, a, b
If Not initOk Then initWerte
'MsgBox oC.Count
If (Not Intersect(Target, Range(r1)) Is Nothing) Or _
(Not Intersect(Target, Range(r2)) Is Nothing) Then
For i = LBound(zOff) To UBound(zOff)
gefunden = 1
a = Range(r1)
b = oC("C" & i)
For z = 1 To UBound(a)
For s = 1 To UBound(a, 2)
If a(z, s)  b(z, s) Then gefunden = 0: Exit For
Next
If gefunden = 0 Then Exit For
Next
If gefunden = 1 Then
a = Range(r2)
b = oC("G" & i)
For z = 1 To UBound(a)
For s = 1 To UBound(a, 2)
If a(z, s)  b(z, s) Then gefunden = 0: Exit For
Next
If gefunden = 0 Then Exit For
Next
End If
If gefunden = 1 Then
'      Range(r3).Value = Sheets(5).Range(r3).Offset(zOff(i)).Value
Range(r3).Resize(UBound(oC("N" & i))) = oC("N" & i)
MsgBox "gefunden - Werte geschrieben"
Exit For
End If
'     MsgBox UBound(a) & " : " & UBound(a, 2) & " : " & UBound(b) & " : " & UBound(b, 2)
'     MsgBox LBound(a) & " : " & LBound(a, 2) & " : " & LBound(b) & " : " & LBound(b, 2)
Next
If gefunden = 0 Then MsgBox "nicht gefunden": Range(r3).ClearContents
End If
End Sub
Sub initWerte()
Dim i&, a
Set oC = CreateObject("scripting.dictionary")
r1 = "C4:C17": r2 = "G4:G10": r3 = "N4:N12" ' hier Bereiche ändern, falls erforderlich
zOff = Array(-2, 15, 32) ' hier weitere Werte, wenn neue Szenarien
For i = LBound(zOff) To UBound(zOff)
a = Sheets(5).Range(r1).Offset(zOff(i))
oC("C" & i) = a
a = Sheets(5).Range(r2).Offset(zOff(i))
oC("G" & i) = a
a = Sheets(5).Range(r3).Offset(zOff(i))
oC("N" & i) = a
Next
initOk = 1
End Sub

Datei: https://www.herber.de/bbs/user/109033.xlsm
Schöne Grüße,
Michael

Sub Vergleich() Dim wksEntryMask As Worksheet, wksSzenarios As Worksheet Set wksEntryMask = Worksheets("entry mask") Set wksSzenarios = Worksheets("szenarios") Dim strVergleich As String, strQuelle As String Dim c As Long, x As Long, lastRow As Long lastRow = wksSzenarios.Cells(Rows.Count, 3).End(xlUp).Row - 13 Application.ScreenUpdating = False With wksEntryMask For c = 4 To 17 'Initial State strQuelle = strQuelle & .Range("C" & c) Next c For c = 4 To 10 'actions / state changes strQuelle = strQuelle & .Range("G" & c) Next c End With With wksSzenarios For c = 2 To lastRow Step 17 'scenarios strVergleich = "" For x = c To c + 13 strVergleich = strVergleich & .Range("C" & x) Next x For x = c To c + 6 strVergleich = strVergleich & .Range("G" & x) Next x If strQuelle = strVergleich Then .Range("N" & c & ":N" & c + 8).Copy wksEntryMask.Range("N4").PasteSpecial xlPasteValues Exit For End If Next c End With Application.CutCopyMode = False Set wksEntryMask = Nothing Set wksSzenarios = Nothing End Sub

Sub Vergleich() Dim wksEntryMask As Worksheet, wksSzenarios As Worksheet Set wksEntryMask = Worksheets("entry mask") Set wksSzenarios = Worksheets("szenarios") Dim strVergleich As String, strQuelle As String Dim c As Long, x As Long, lastRow As Long lastRow = wksSzenarios.Cells(Rows.Count, 3).End(xlUp).Row - 13 Dim Found As Boolean Application.ScreenUpdating = False With wksEntryMask For c = 4 To 17 'Initial State strQuelle = strQuelle & .Range("C" & c) Next c For c = 4 To 10 'actions / state changes strQuelle = strQuelle & .Range("G" & c) Next c End With With wksSzenarios For c = 2 To lastRow Step 17 'scenarios strVergleich = "" For x = c To c + 13 strVergleich = strVergleich & .Range("C" & x) Next x For x = c To c + 6 strVergleich = strVergleich & .Range("G" & x) Next x If strQuelle = strVergleich Then .Range("N" & c & ":N" & c + 8).Copy wksEntryMask.Range("N4").PasteSpecial xlPasteValues Found = True Exit For End If Next c End With Application.CutCopyMode = False If Found = False Then wksEntryMask.Range("N4:N12").Value = "not defined" Set wksEntryMask = Nothing Set wksSzenarios = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

245 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Listen mit Listen vergleichen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

245 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread