Datenüberprüfung und Auswahlliste

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Private Sub Worksheet_Change(ByVal Target As Range) Dim rngBereich As Range Dim oDic As Object, oArrLst As Object Dim tmpAr(), strAusgabe$ Dim nCount&, A& Set rngBereich = Intersect(Columns(2), Target) If rngBereich Is Nothing Then Exit Sub If rngBereich.Rows(rngBereich.Rows.Count) = 1 Then Exit Sub Set oDic = CreateObject("Scripting.Dictionary") Set oArrLst = CreateObject("System.collections.arraylist") For Each rngBereich In rngBereich If rngBereich.Row > 1 Then tmpAr = Range(Cells(1, 2), Cells(rngBereich.Row - 1, 3)) For A = 1 To Ubound(tmpAr) If tmpAr(A, 1) = rngBereich.Value Then If Not oDic.Exists(tmpAr(A, 2)) Then oDic(tmpAr(A, 2)) = 0 oArrLst.Add tmpAr(A, 2) End If End If Next A If oDic.Count > 0 Then oArrLst.Sort strAusgabe = Join(oArrLst.ToArray, ",") End If With rngBereich.Offset(0, 1).Validation .Delete If oDic.Count > 0 Then .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=strAusgabe .IgnoreBlank = True .InCellDropdown = True .ShowInput = False .ShowError = False End If End With oArrLst.Clear oDic.RemoveAll strAusgabe = "" End If Next rngBereich End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim rngBereich As Range Dim oArrLst As Object Dim tmpAr(), strAusgabe$ Dim nCount&, A& Set rngBereich = Intersect(Columns(2), Target) If rngBereich Is Nothing Then Exit Sub If rngBereich.Rows(rngBereich.Rows.Count) = 1 Then Exit Sub Set oArrLst = CreateObject("System.collections.arraylist") For Each rngBereich In rngBereich If rngBereich.Row > 1 Then tmpAr = Range(Cells(1, 2), Cells(rngBereich.Row - 1, 3)) For A = 1 To Ubound(tmpAr) If tmpAr(A, 1) = rngBereich.Value Then If Not oArrLst.Contains(tmpAr(A, 2)) Then oArrLst.Add tmpAr(A, 2) End If End If Next A If oArrLst.Count > 0 Then oArrLst.Sort strAusgabe = Join(oArrLst.ToArray, ",") End If With rngBereich.Offset(0, 1).Validation .Delete If oArrLst.Count > 0 Then .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=strAusgabe .IgnoreBlank = True .InCellDropdown = True .ShowInput = False .ShowError = False End If End With oArrLst.Clear strAusgabe = "" End If Next rngBereich End Sub

Hallo,
sorry, dass ich mich jetzt erst melde, war die ganze Zeit nicht online.
So geht es auch mit den Spalte B und C; C und D
Habe den Code noch Kommentiert, vielleicht ist es so einfacher zu verstehen.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngBereich As Range
Dim oArrLst As Object
Dim tmpAr(), strAusgabe$
Dim nCount&, A&

'Prüfen ob Eingabe i Spalte B oder D 
Set rngBereich = Intersect(Range(Columns(2), Columns(4)), Target)
If rngBereich Is Nothing Then Exit Sub
'ist der Eingabebereich nicht nicht nur in Zeile 1 
If rngBereich.Rows(rngBereich.Rows.Count) = 1 Then Exit Sub
'Object collections.arraylist Initialisieren 
Set oArrLst = CreateObject("System.collections.arraylist")
'Schleife über eingabe in Spalte 
For Each rngBereich In rngBereich
    'ist Zelle nicht in Zeile 1 
    If rngBereich.Row > 1 Then
            'Rangebereich in einem Array aufnehmen 
            tmpAr = Range(Cells(1, rngBereich.Column), Cells(rngBereich.Row - 1, rngBereich.Column + 1))
            'Schleife über Array 
            For A = 1 To Ubound(tmpAr)
                'ist Array = Eingabe 
                If tmpAr(A, 1) = rngBereich.Value Then
                    'Ist eintrag nicht in der Collection? 
                    If Not oArrLst.Contains(tmpAr(A, 2)) Then
                        'nein, dann in Collection aufnehmen 
                        oArrLst.Add tmpAr(A, 2)
                    End If
                End If
            Next A
            'wurden Einträge in Collection aufgenommen? 
            If oArrLst.Count > 0 Then
                'Collection Sortieren 
                oArrLst.Sort
                'Collection als Array zu einen String mit Trennzeichen 
                strAusgabe = Join(oArrLst.ToArray, ",")
            End If

            'Gültigkeit Liste erstellen 
            With rngBereich.Offset(0, 1).Validation
                .Delete 'löschen vorhandene 
                If oArrLst.Count > 0 Then 'neu erstellen 
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                    xlBetween, Formula1:=strAusgabe
                    .IgnoreBlank = True
                    .InCellDropdown = True
                    .ShowInput = False
                    .ShowError = False
                End If
            End With
            'Collection leeren 
            oArrLst.Clear
            'String löschen 
            strAusgabe = ""
    End If

Next rngBereich

End Sub

Gruß Tino

Hallo René,
ich habe hier noch eine 95%-Lösung auf Basis von Excel4-Funktion in definierten Namen :
https://www.herber.de/bbs/user/71007.xls
Nach Eingabe eines Produktes in Spalte B erscheint in Spalte C automatisch die Auswahl der bisherigen Sorten dieses Produkts. Der Lösungsweg ist in der Mappe dokumentiert !
Zwei kleine Knackpunkte enthält diese Lösung (daher auch keine 100%-Lösung sondern nur 95%) :
- Beim Öffnen der Mappe erscheint ein Warnhinweis bzgl. "Excel4-Makrofunktionen" (kein VBA !), den man bestätigen muss
- Klick man einen bereits vorhandenen Datensatz ohne Eingabe in Spalte B an, muss man die Auswahlliste evtl. per Taste F9 aktualisieren !
Ich hoffe, dass Dir (oder anderen) diese Lösung auch weiterhilft, auch wenn ich die Lösung von Klaus M.vdT praktikabler (wenn auch nicht einfacher) finde !
Gruß, NoNet

Beliebteste Forumthreads (12 Monate)

Datenüberprüfung und Auswahlliste

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread