Anzeige
Archiv - Navigation
1228to1232
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

SVERWEIS-ähnliche Abfrage, mit Sortiermöglichkeit

SVERWEIS-ähnliche Abfrage, mit Sortiermöglichkeit
Peter
Guten Tag
Ich habe mir eine Funktion gebastelt, welche mir ähnlich SVERWEIS ein zum Suchwert zugehöriger Wert zurück gibt, allerdings kann ich dann abfragen, nach dem 1., 2, .... Auftreten. In der hochgeladenen Datei habe ich zwei Beispiele dargestellt.
Nun möchte ich die Funktion erweitern und ein weiteres, optionales Argument übergeben. Wenn 0 oder nichts übergeben wird, soll die Auswertung unverändert sein.
Wenn die Zahl 1 übergeben wird, sollen die Werte aufsteigend sortiert, zurückgegeben werden. Wenn die Zahl 2 übergeben wird, sollen die Werte absteigend sortiert zurückgegeben werden.
Beispiel:
Suchwert XX
XX - BA
XX - AB
XX - CC
Variante optionales Argument 0 oder nichts:
Rückgabe in der Reihenfolge: BA, AB, CC
Variante optionales Argument 1:
Rückgabe in der Reihenfolge: AB, BA, CC
Variante optionales Argument 2:
Rückgabe in der Reihenfolge CC, BA, AB
Mir ist nicht klar, wie diese Erweiterung im Code zu erfolgen hat. Kann mir jemand weiterhelfen?
Danke und Gruss, Peter
https://www.herber.de/bbs/user/76391.xlsm
AW: SVERWEIS-ähnliche Abfrage, mit Sortiermöglichkeit
30.08.2011 11:43:40
Rudi
Hallo,
deine Anforderung ist ein Widerspruch in sich.
Es wird ja nur 1 Wert zurückgegeben. Wie soll der sortiert werden?
Gruß
Rudi
SVERWEIS-ähnliche VBA-Funktion
30.08.2011 12:37:43
Erich
Hi Peter,
probier mal

Option Explicit   ' immer zu empfehlen
Public Function XSVERWEIS(strSuchwert As String, _
rngSuchBereich As Range, _
rngFindBereich As Range, _
xtes As Long, _
blnAuf As Boolean)
Dim lngZaehler As Long, arrSuch, arrFind, zz As Long
lngZaehler = 0 'Zähler "xtes" Auftreten auf Null stellen
arrSuch = rngSuchBereich
arrFind = rngFindBereich
'''Übereinstimmender Suchwert ermitteln
For zz = IIf(blnAuf, 1, UBound(arrSuch)) To IIf(blnAuf, UBound(arrSuch), 1) _
Step IIf(blnAuf, 1, -1)
If arrSuch(zz, 1) = strSuchwert Then lngZaehler = lngZaehler + 1
'''Übereinstimmung xtes-Auftreten ermitteln
If lngZaehler = xtes Then
'''ist auch die zweite Übereinstimmung gegeben, wird die Funktion verlassen
'''und der Eintrag aus dem FindBereich zurückgegeben
XSVERWEIS = rngFindBereich.Cells(zz, 1)
Exit Function
End If
Next
'''gibt es keine Übereinstimmung für Suchwert und xtes Auftreten, wird nichts zurückgegeben
XSVERWEIS = ""
End Function
Die Fkt. kannst du aufrufen mit
=XSVERWEIS($F5;xSUCH;xFIND1;H$3;0) für absteigend,
=XSVERWEIS($F5;xSUCH;xFIND1;H$3;1) für aufsteigend.
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Anzeige
AW: SVERWEIS-ähnliche Abfrage, mit Sortiermöglichkeit
30.08.2011 12:45:50
Rudi
Hallo,
teste mal

Public Function XSVERWEIS(strSuchwert As String, _
rngSuchBereich As Range, _
rngFindBereich As Range, _
xtes As Long, _
Optional bytSort)
Dim lngSpaAbw As Long, rCell As Range
Dim arrErg, objErg As Object, vntTmp, i As Integer, j As Integer
Set objErg = CreateObject("Scripting.Dictionary")
lngSpaAbw = rngFindBereich.Column - rngSuchBereich.Column 'Ermitteln der Spaltenabweichung
'''Übereinstimmender Suchwert ermitteln
For Each rCell In rngSuchBereich
If rCell.Value = strSuchwert Then
objErg(rCell.Offset(, lngSpaAbw).Value) = 0
End If
Next
If objErg.Count = 0 Then
XSVERWEIS = "#NV"
Exit Function
End If
arrErg = objErg.keys
If Not IsMissing(bytSort) Then
Select Case bytSort
Case 1
For i = 0 To UBound(arrErg) - 1
For j = i + 1 To UBound(arrErg)
If arrErg(j)  arrErg(i) Then
vntTmp = arrErg(j)
arrErg(j) = arrErg(i)
arrErg(i) = vntTmp
End If
Next
Next
End Select
End If
If xtes > objErg.Count Then
XSVERWEIS = ""
Else
XSVERWEIS = arrErg(xtes - 1)
End If
End Function

Gruß
Rudi
Anzeige
AW: SVERWEIS-ähnliche Abfrage, mit Sortiermöglichkeit
30.08.2011 21:40:54
Peter
Hallo zusammen
Vielen Dank für eure Antworten.
Ich habe die beiden Versionen ausgewertet.
Bei Rudi hat es auf Anhieb geklappt (optionales Argument "" oder 0; 1; 2). Das ist nun eine tolle UDF. Super.
@Erich: wenn ich mich bei meiner Auswertung nicht vertan habe, erhalte ich mit optionalem Argument 1 oder 2 das gleiche Ergebnis wie mit meiner bisherigen Version (nicht sortiert). Mit 0 ist für mich die Systematik nicht ersichtlich.
Nochmals besten Dank und Gruss, Peter
https://www.herber.de/bbs/user/76406.xlsm
Anzeige
war ein Missverständnis - neue Alternative
31.08.2011 09:27:59
Erich
Hi Peter,
den Sort hatte ich nicht richtig verstanden. Ich hatte nicht an einen Sort nach den werten,
sondern nach dem Auftreten in rngSuchBereich, also Sort nach Zdeilennummer, gedacht.
Hier eine Variante:

Public Function EGXSVERWEIS(strSuchwert As String, _
rngSuchBereich As Range, _
rngFindBereich As Range, _
xtes As Long, _
Optional bytSort As Byte = 0)
Dim objErg As Object, arrSuch, arrErg, zz As Long
Set objErg = CreateObject("Scripting.Dictionary")
arrSuch = rngSuchBereich
For zz = 1 To UBound(arrSuch)       '''Übereinstimmende Suchwerte ermitteln
If arrSuch(zz, 1) = strSuchwert Then objErg(rngFindBereich(zz, 1)) = 0
Next zz
If objErg.Count = 0 Then            ''' Abbrüche
EGXSVERWEIS = "#NV":          Exit Function
ElseIf xtes > objErg.Count Then
EGXSVERWEIS = "":             Exit Function
End If
arrErg = objErg.keys                  ''' Ergebnisarray, Sort
If bytSort Then QuickSort_Feld arrErg, 0, UBound(arrErg), bytSort = 1
EGXSVERWEIS = arrErg(xtes - 1)
End Function
Private Sub QuickSort_Feld(DasFeld, StartUnten, EndeOben, Absteigend As Boolean)
'QuickSort Standard  -  von www.online-excel.de/excel/singsel_vba.php?f=24
Dim iUnten As Long, iOben, iMitte, y
iUnten = StartUnten
iOben = EndeOben
iMitte = DasFeld((StartUnten + EndeOben) / 2)
While iUnten  StartUnten)
iOben = iOben - 1
Wend
Else
While (DasFeld(iUnten) > iMitte And iUnten  DasFeld(iOben) And iOben > StartUnten)
iOben = iOben - 1
Wend
End If
If (iUnten 
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Anzeige
AW: war ein Missverständnis - neue Alternative
31.08.2011 23:08:33
Peter
Hallo Erich
Besten Dank.
Nun erhalte ich mit deinem Code die gleichen (richtigen) Ergebnisse.
Ich hoffe, dass ich mich in die Codes Schrittweise einarbeiten kann, um zu verstehen, wann was genau passiert.
Nochmals vielen Dank und Gruss, Peter

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige