Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1096to1100
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

Mehrstufige Suche nach Nachfolger

Mehrstufige Suche nach Nachfolger
Alexander
Hallo Forum,
gegeben ist eine Tabelle mit Artikeln.
In Spalte A steht die Artikelnummer des jeweiligen Artikels.
In Spalte I steht ggf. der direkte Vorgänger (Artikelnummer) zu diesem Artikel.
In Spalte J steht ggf. der direkte Nachfolger (Artikelnummer) zu diesem Artikel.
Ich versuche nun in Spalte K die Artikelnumer desjenigen Artikels auszugeben, welcher der jüngste Nachfolger ist (das ist derjenige, der selbst keinen Nachfolger mehr hat).
Erschwert wird die Sache, da ein Artikel in mehreren Stufen durch Nachfolgeartikel ersetz worden sein kann. Also aus Artikel A wurde Artikel B dann Artikel C und zuletzt Artikel D.
Bei den Artikeln A, B und C soll nun in Spalte K die Artikelnummer von Artikel D ausgegeben werden.
Alle bisherigen Lösungsversuche sind gescheitert und ich bin mit meinem Latein am Ende.
Vielleich kann mir jemand von euch auf die Sprüpnge helfen.
Danke & Gruß,
Alex.

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Mehrstufige Suche nach Nachfolger
17.08.2009 15:33:33
ChrisL
Hallo Alex
Probier mal hiermit...
Sub t()
Dim iZeile As Long, bStop As Boolean
Dim tempNr As Long, tempZeile As Long
For iZeile = 1 To Range("A65536").End(xlUp).Row
If Cells(iZeile, 10) = "" Then
Cells(iZeile, 11) = Cells(iZeile, 1)
Else
tempNr = Cells(iZeile, 10)
bStop = False
Do Until bStop = True
tempZeile = Application.Match(tempNr, Columns(1), 0)
If Cells(tempZeile, 10) = "" Then
bStop = True
tempNr = Cells(tempZeile, 1)
Else
tempNr = Cells(tempZeile, 10)
End If
Loop
Cells(iZeile, 11) = tempNr
End If
Next iZeile
End Sub
cu
Chris
Anzeige
AW: Mehrstufige Suche nach Nachfolger
17.08.2009 16:14:18
Alexander
Hallo Chris,
vielen Dank. Leider erzeugt die Zeile "tempNr = Cells(iZeile, 10)" einen Fehler "Typen unverträglich".
Dies scheint abhängig zu sein von der Länge der Tabelle bzw. der Anzahl Zeilen, die man überprüfen lässt. Excel 2007 steigt bei mir in Zeile 3847 mit o. g. Fehlermeldung aus. Prüft man hingegen nur 3846 Zeilen, dann scheint es zu funktionieren.
AW: Mehrstufige Suche nach Nachfolger
17.08.2009 16:20:57
Alexander
Ich glaube, es liegt daran dass in meiner Tabelle in Zeile 3847 in Spalte J ein Nachfolger genannt ist, der in der Tabelle gar nicht nicht vorkommt. Das Problem liegt also offenbar nicht bei den Typen, sondern in der Tabelle.
Hast du vielleicht einen Vorschlag, wie ich diesen Fehler abfangen kann?
Danke & Gruß
Alex
Anzeige
AW: Mehrstufige Suche nach Nachfolger
17.08.2009 19:40:16
ChrisL
Hallo Alex
So müsste es gehen...
Sub t()
Dim iZeile As Long, bStop As Boolean
Dim tempNr As Long, tempZeile As Long
For iZeile = 1 To Range("A65536").End(xlUp).Row
If Cells(iZeile, 10) = "" Then
Cells(iZeile, 11) = Cells(iZeile, 1)
Else
tempNr = Cells(iZeile, 10)
If WorksheetFunction.CountIf(Columns(1), tempNr) > 0 Then
bStop = False
Do Until bStop = True
tempZeile = Application.Match(tempNr, Columns(1), 0)
If Cells(tempZeile, 10) = "" Then
bStop = True
tempNr = Cells(tempZeile, 1)
Else
tempNr = Cells(tempZeile, 10)
End If
Loop
Cells(iZeile, 11) = tempNr
Else
Cells(iZeile, 11) = "Fehler"
End If
End If
Next iZeile
End Sub

cu
Chris
Anzeige
AW: Mehrstufige Suche nach Nachfolger
17.08.2009 16:25:31
Alexander
Ich glaube, es liegt daran dass in meiner Tabelle in Zeile 3847 in Spalte J ein Nachfolger genannt ist, der in der Tabelle gar nicht nicht vorkommt. Das Problem liegt also offenbar nicht bei den Typen, sondern in der Tabelle.
Hast du vielleicht einen Vorschlag, wie ich diesen Fehler abfangen kann?
Danke & Gruß
Alex
AW: Mehrstufige Suche nach Nachfolger
17.08.2009 16:27:46
Alexander
Hallo Chris,
es scheint an der Tabelle selbst zu liegen. Bei einem Artikel ist in Spalte J ein Nachfolger gepflegt, welcher nicht in der Tabelle vorkommt.
Hättest du noch eine Fehlerbehandlung für mich?
Danke & Gruss,
Alex.
AW: Mehrstufige Suche nach Nachfolger
19.08.2009 14:18:01
Wolli
Hallo Alex, unbeleckt von den bisherigen Antworten habe ich spaßeshalber mal eine eigene Funktion geschrieben. Syntax: =Nachfolger(Artikel,Artikelbereich,Nachfolgerbereich).
Zurückgegeben wird jeweils der letzte Nachfolger oder eine Fehlermeldung.
Viel Spaß, Grüße, Wolfgang

Option Explicit
Function Nachfolger(Suchwert As Variant, Wertebereich As Range, _
Nachfolgerbereich As Range) As Variant
Dim Nachfolgewert As Variant, _
Zirkelspeicher() As Variant, _
TempRange As Range, _
i As Long, _
Zaehler As Long
On Error GoTo Fehlerabfang
'Nur einspaltige und gleichgroße Bereiche zulassen
If Wertebereich.Columns.Count > 1 Or _
Nachfolgerbereich.Columns.Count > 1 Or _
Wertebereich.Cells.Count  Nachfolgerbereich.Cells.Count Then
Err.Raise 514
End If
Nachfolgewert = Suchwert
'Diese Schleife wird für jeden gefundenen Nachfolger durchlaufen.
Do
'letzten Nachfolger als neuen Suchwert einsetzen
Suchwert = Nachfolgewert
'Finden, ob und wo der Suchwert steht
Set TempRange = Wertebereich.Find(what:=Suchwert, lookat:=xlWhole)
'Wenn Suchwert vorhanden, ...
If Not (TempRange Is Nothing) Then
Set TempRange = Nachfolgerbereich.Cells(TempRange.Row - _
Wertebereich.Cells(1).Row + 1)
'... Nachfolger bestimmen. Wenn es keinen Nachfolger gibt,
'hier die Schleife beenden.
If IsEmpty(TempRange) Then
Exit Do
End If
'Nachfolgerwert ermitteln
Nachfolgewert = TempRange
'Prüfen, ob der Nachfolgerwert bereits vorkam (Das darf nicht sein!)
For i = 1 To Zaehler
If Nachfolgewert = Zirkelspeicher(i) Then
Err.Raise 516
End If
Next i
'Nachfolgewert für die nächste Prüfung speichern.
Zaehler = Zaehler + 1
ReDim Preserve Zirkelspeicher(Zaehler)
Zirkelspeicher(Zaehler) = Nachfolgewert
Else
Err.Raise 515
End If
Loop
'Funktionsrückgabewert eingeben und Funktion beenden.
Nachfolger = Nachfolgewert
Exit Function
Fehlerabfang:
'Die möglichen Fehler abfangen und zurückgeben.
Select Case Err.Number
Case 514
Nachfolger = "Bereiche sind nicht einspaltig und gleichgroß!"
Case 515
Nachfolger = "Wert " & CStr(Suchwert) & " fehlt in der Liste!"
Case 516
Nachfolger = "Zirkelbezug!"
End Select
End Function

Anzeige
kl. Verbesserung
19.08.2009 14:26:00
Wolli
mit Abfang von Werten ohne Nachfolger!

Option Explicit
Function Nachfolger(Suchwert As Variant, Wertebereich As Range, _
Nachfolgerbereich As Range) As Variant
Dim Nachfolgewert As Variant, _
Zirkelspeicher() As Variant, _
TempRange As Range, _
i As Long, _
Zaehler As Long
On Error GoTo Fehlerabfang
'Nur einspaltige und gleichgroße Bereiche zulassen
If Wertebereich.Columns.Count > 1 Or _
Nachfolgerbereich.Columns.Count > 1 Or _
Wertebereich.Cells.Count  Nachfolgerbereich.Cells.Count Then
Err.Raise 514
End If
Nachfolgewert = Suchwert
'Diese Schleife wird für jeden gefundenen Nachfolger durchlaufen.
Do
'letzten Nachfolger als neuen Suchwert einsetzen
Suchwert = Nachfolgewert
'Finden, ob und wo der Suchwert steht
Set TempRange = Wertebereich.Find(what:=Suchwert, lookat:=xlWhole)
'Wenn Suchwert vorhanden, ...
If Not (TempRange Is Nothing) Then
Set TempRange = Nachfolgerbereich.Cells(TempRange.Row - _
Wertebereich.Cells(1).Row + 1)
'... Nachfolger bestimmen. Wenn es keinen Nachfolger gibt,
'hier die Schleife beenden.
If IsEmpty(TempRange) Then
Exit Do
End If
'Nachfolgerwert ermitteln
Nachfolgewert = TempRange
'Prüfen, ob der Nachfolgerwert bereits vorkam (Das darf nicht sein!)
For i = 1 To Zaehler
If Nachfolgewert = Zirkelspeicher(i) Then
Err.Raise 516
End If
Next i
'Nachfolgewert für die nächste Prüfung speichern.
Zaehler = Zaehler + 1
ReDim Preserve Zirkelspeicher(Zaehler)
Zirkelspeicher(Zaehler) = Nachfolgewert
Else
Err.Raise 515
End If
Loop
'Funktionsrückgabewert eingeben (sofern überhaupt ein Wert gefunden
'wurde) und Funktion beenden
If Zaehler > 0 Then Nachfolger = Nachfolgewert Else Nachfolger = ""
Exit Function
Fehlerabfang:
'Die möglichen Fehler abfangen und zurückgeben.
Select Case Err.Number
Case 514
Nachfolger = "Bereiche sind nicht einspaltig und gleichgroß!"
Case 515
Nachfolger = "Wert " & CStr(Suchwert) & " fehlt in der Liste!"
Case 516
Nachfolger = "Zirkelbezug!"
End Select
End Function

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige