AW: VBA-Lösung suchen / eintragen
29.07.2011 19:50:00
fcs
Hallo namensvetter,
mein Vorschlag ist eine VBA-Lösung, die hier als Tabellenformel benutzt wird.
Da meine Funktion das von dir in der Beispieltabelle angegebene Ergebnis anzeigt, weiss ich nicht wo nun das Problem ist. Wenn du jetzt mehr Zeilen in der Suchtabelle hast, dann muss du in den Formeln natürlich die Zeilenwerte anpassen.
aus
=fncSUcheSpezial(A2:G2;Suchtabelle!$A$2:$A$5;Suchtabelle!$AF$2:$AL$5)
wird dann z.B.
=fncSUcheSpezial(A2:G2;Suchtabelle!$A$2:$A$1250;Suchtabelle!$AF$2:$AL$1250)
Die Rechenzeit geht dann natürlich entsprechend hoch.
Nachfolgend eine VBA-Lösung, die die gleiche Berechnungsmethode verwendet und die Ergebnisse in Spalte H der Ausgangstabelle einträgt.
Deine neuen/ergänzenden Beschreibungen zum Problem sind leider nicht klarer als in der ursprünglichen Frage.
Gruß
Franz
Sub TrefferSuche()
Dim wksAusgang As Worksheet, wksSuch As Worksheet
Dim Zeile As Long, ZeileL As Long
Dim rErgebnis As Range, rSuchen As Range
Set wksAusgang = Worksheets("Ausgangstabelle")
Set wksSuch = Worksheets("Suchtabelle")
With wksSuch
'Letzte Datenzeile in Spalte A
ZeileL = .Cells(.Rows.Count, 1).End(xlUp).Row
'Ergebnis-Daten in Spalte A
Set rErgebnis = .Range(.Cells(2, 1), .Cells(ZeileL, 1))
'Suchdaten in Spalten AF (32) bis AL (38)
Set rSuchen = .Range(.Cells(2, 32), .Cells(ZeileL, 38))
End With
With wksAusgang
ZeileL = .Cells(.Rows.Count, 1).End(xlUp).Row
For Zeile = 2 To ZeileL
.Cells(Zeile, 8) = fncSucheSpezial(Suchwerte:=.Range(.Cells(Zeile, 1), .Cells(Zeile, 7)), _
_
Ergebniswerte:=rErgebnis, Vergleichswerte:=rSuchen)
Next
End With
End Sub
Public Function fncSucheSpezial(Suchwerte As Range, Ergebniswerte As Range, _
Vergleichswerte As Range) As String
'Sucht die Suchwerte in den Zeilen von Vergleichswerte _
Werden alle Suchwerte in einer Zeile von Vergleichswerte gefunden, dann wird _
der Wert aus der Ergebniswerte zurückgegeben
Dim Zeile As Long, Spalte As Long, Bereich As Range, bAlle As Boolean
Dim vSpalte, vWert
fncSucheSpezial = "nix gefunden" 'Ergebnis, wenn keine Übereinstimung gefunden wurde
For Zeile = 1 To Vergleichswerte.Rows.Count
bAlle = True
With Vergleichswerte
Set Bereich = Range(.Cells(Zeile, 1), .Cells(Zeile, .Columns.Count))
End With
For Spalte = 1 To Suchwerte.Columns.Count
vWert = Suchwerte.Cells(1, Spalte).Value
If vWert "" Then
vSpalte = Application.Match(vWert, Bereich, 0)
If IsError(vSpalte) Then bAlle = False: Exit For
End If
Next Spalte
If bAlle = True Then
fncSucheSpezial = Ergebniswerte.Cells(Zeile, 1).Value
Exit Function
End If
Next Zeile
End Function