Office: (Office 2010) VBA- mehrere Spalten nach mehren Suchkriterien durchsuchen

axcel4129 · 29. Oktober 2014

Liebe Excel Freaks,

Hab folgende Herausforderungen. In der hochgeladenen Datei habe ich rechts oben eine Suchmatrix und unten links eine Zielmatrix. Ich würde gerne die Zielmatrix nach den einzelnen Spalten durchsuchen und sobald es eine Zeile gibt in der alle Einträge innerhalb einer Zeile mit jener Zeile der Suchmatrix übereinstimmen, den Betrag in Spalte F durch jenen aus der Suchmatrix Spalte O ersetzten und obendrein in Spalte G eine "1" schreiben.

Siehe auch Tabellenblatt Lösung.

Die beiden letztegenannten Dinge sind vermutlich die einfachste Übung.

Die Frage ist, ob es einen Weg gibt, wie man simultan (oder auch hintereinander) mehrer Spalten aus der Suchmatrix durchsuchen kann, bis man irgendwann jenes findet, wo alle Suchwerte in der gleichen Zeile pro Spalte stehen.

Es können in allen Spalten der Zielmatrix Werte mehrfach vorkommen.

Es müssen nicht zwingend alle Tupel aus der Suchmatrix in Zielmatrix gefunden werden. Manche können allerdings auch doppelt vorkommen (wie in der Lösung). In diesem Fall ist das obere in der Suchmatrix auch das obere in Zielmatrix.

Eine Lösung, die mir eingefallen wäre, wäre die .Find Function mit anschließender Überprüfung der Nebenspalten in derselben Zeile auf Übereinstimmung und wenn nicht, dann das ganze wiederholen mit find lookAfter:= Zeile + 1.

Nur müsste man diesen Code sooft reinschreiben, wie man Einträge in der Zielmatrix hat, was wiederum variabel sein kann...

Weiß jemand von euch eine Lösung?

Danke schonmal.

LG axcel4129

:)

axcel4129 · 31. Oktober 2014

Hello,

Habe mittlerweile die Sache schon selbst gelöst.

Ich nehme einfach sämtliche einzelnen Arrays und füge die dort hinterlegten Werte in ein Gesamtarray zusammen (mit "," getrennt). Das Ganze jeweils für Quell- und Zielmatrix

Dieser String ist dann einmalig in der Erkennung und man kann es eindeutig einer bestimmten Zeile zuordnen.

Bezüglich der Doppelkennung lässt sich dies auch noch mit einer If Bedingung und Sprungmarke lösen.

LG axcel4129

xlph · 1. November 2014

Hallo,

hier noch eine typische Array-Dict-Variante für einen Tabellen-Abgleich.

Code:

Sub Abgleich_xlph()

Dim rngQuelle As Range
Dim avarQuelle As Variant
Dim lngQz As Long
Dim lngQs As Long

Dim rngZiel As Range
Dim avarZiel As Variant
Dim lngZz As Long
Dim lngZs As Long

Dim strID As String
Dim dicMatch As Object

Dim avarQz As Variant

Set dicMatch = CreateObject("scripting.dictionary")

Set rngQuelle = Tabelle4.Range("J2:O7")
avarQuelle = rngQuelle.Value

Set rngZiel = Tabelle4.Range("A11:G26")
avarZiel = rngZiel.Value

' Quell-IDs zwischnspeichern
For lngQz = LBound(avarQuelle) To UBound(avarQuelle)
strID = vbNullString
For lngQs = LBound(avarQuelle, 2) + 1 To UBound(avarQuelle, 2) - 1
strID = strID & "_" & avarQuelle(lngQz, lngQs)
Next
If Not dicMatch.Exists(strID) Then _
Set dicMatch(strID) = CreateObject("scripting.dictionary")
dicMatch(strID)(lngQz) = False
Next

' mit Ziel-IDs vergleichen und Ziel-Array manipulieren
For lngZz = LBound(avarZiel) To UBound(avarZiel)
strID = vbNullString
For lngZs = LBound(avarZiel, 2) + 1 To UBound(avarZiel, 2) - 2
strID = strID & "_" & avarZiel(lngZz, lngZs)
Next
If dicMatch.Exists(strID) Then
avarQz = dicMatch(strID).Keys
If UBound(avarQz) > -1 Then
avarZiel(lngZz, 6) = avarQuelle(avarQz(0), 6)
avarZiel(lngZz, 7) = 1
dicMatch(strID).Remove avarQz(0)
Else
avarZiel(lngZz, 7) = "?"
End If
End If
Next

' Ziel-Array ausgeben
rngZiel.Formula = avarZiel

Set rngQuelle = Nothing
Set rngZiel = Nothing

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

HS(V) · 1. November 2014

Hallo,

Hier auch noch eine einfache Stringvergleich.
Code:

Sub hsv()
Dim cl As Range, c As Range, firstaddress As String
For Each cl In Columns(11).SpecialCells(2).Offset(1).SpecialCells(2)
Set c = Columns(2).Find(cl, , xlValues, xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
If Join(Application.Index(cl.Resize(, 4).Value, 1, 0)) = Join(Application.Index(c.Resize(, 4).Value, 1, 0)) Then
c.Offset(, 5) = 1
End If
Set c = Columns(2).FindNext(c)
Loop While Not c Is Nothing And c.Address firstaddress
End If
Next cl
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

axcel4129 · 2. November 2014

Hallo Hsv,

Da dein Code sehr kurz ist, würde ich ihn gerne etwas besser verstehen um mir in Zukunft mein Leben leichter zu machen.

Was bewirken die Methoden ".SpecialCells(2).Offset(1).SpecialCells(2)" in der Suchrange c1?

Was untersucht die Funkltionen Join bzw. die Worksheet Function Index mit Resize in diesem Zusammenhang in der Zielmatrix?

If Join(Application.Index(cl.Resize(, 4).Value, 1, 0)) = Join(Application.Index(c.Resize(, 4).Value, 1, 0)) Then

Danke vielmals!

Lg axcel

HS(V) · 3. November 2014

Hallo Michael,

Code:

Columns(11).SpecialCells(2).Offset(1).SpecialCells(2)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

sind alle Zellen mit Konstanten in Spalte K (nicht Zelle K1 und keine leeren Zellen).
In Worten.
Code:

Columns("K").SpecialCells(xltypeconstants).Offset(1).SpecialCells(xltypeconstants)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Setz ein MessageBox für die Codezeile und du verstehst es. *wink.gif*
Code:

msgbox Join(Application.Index(cl.Resize(, 4).Value, 1, 0))
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

xlph · 3. November 2014

\@HS(V),

die Übernahme des Betrages fehlt noch.

HS(V) · 4. November 2014

Hallo @xlph,

Du meinst ?
Code:

msgbox Join(Application.Index(cl.Resize(, 5).Value, 1, 0))
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

xlph · 4. November 2014

Hallo,

Das soll ja Sinn des Makros sein - den Betrag zu übertragen und eine Spalte
weiter den Datensatz mit einer '1' kennzeichnen.

Sieh dir Ist- und Soll-Zustand noch mal genau an.
Die Schwierigkeit liegt darin, dass doppelte Datensätze in beiden Tabellen vorhanden ist, jedoch in der Quell-Tabelle mit unterschiedlichem Betrag.

HS(V) · 4. November 2014

Hallo,

Es gibt zwei verschiedene Dateien, und ich habe die erste verwendet.

Neuen code.
Code:

Sub hsv()
Dim cl As Range, c As Range, firstaddress As String, y As Long
For Each cl In Columns(11).SpecialCells(2).Offset(1).SpecialCells(2)
y = 0
Set c = Columns(2).Find(cl, , xlValues, xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
If Join(Application.Index(cl.Resize(, 4).Value, 1, 0)) = Join(Application.Index(c.Resize(, 4).Value, 1, 0)) Then
y = y + 1
If y = 1 Then
c.Offset(, 4) = cl.Offset(, 4).Value
c.Offset(, 5) = 1
Else
c.Offset(, 5) = "?"
End If
End If
Set c = Columns(2).FindNext(c)
Loop While Not c Is Nothing And c.Address firstaddress
End If
Next cl
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

pefeu · 4. November 2014

Hallo xlph,

dann füge noch folgende Zeile in das Makro ein:

PHP:

c.Offset(, 4) = cl.Offset(, 4)

xlph · 4. November 2014

Hallo,

vergleicht einfach euer Ergebnis mit dem Soll in Spalte F und G im Blatt
'Lösung'. Dann seht ihr, dass das nicht das gewünschte Ergebnis ist.

HS(V) · 4. November 2014

Hallo,

Ich glaube, wir beide haben das gleiche Ergebnis.

Office: (Office 2010) VBA- mehrere Spalten nach mehren Suchkriterien durchsuchen

VBA- mehrere Spalten nach mehren Suchkriterien durchsuchen

VBA- mehrere Spalten nach mehren Suchkriterien durchsuchen

VBA- mehrere Spalten nach mehren Suchkriterien durchsuchen

VBA- mehrere Spalten nach mehren Suchkriterien durchsuchen

VBA- mehrere Spalten nach mehren Suchkriterien durchsuchen

VBA- mehrere Spalten nach mehren Suchkriterien durchsuchen - Similar Threads - VBA Spalten mehren

Spalten wieder einblenden per VBA

Wie Spalten per VBA mit definierten Spaltenbreiten einfügen ?

VBA: Spalten auf anderen Worksheeds in der Mappe ausblenden.

Primärschlüssel/Fremdschlüssel aus 2.Tabelle automatisch einfügen

Werte der letzten Zelle einer Spalte in mehreren Tabellenblättern ermitteln

VBA mehrere Spalten abfragen, kopieren einfügen

VBA zum Kopieren mehrerer Bereiche wenn Bedingung erfüllt