Auswahlanpassung bei Daten Gültigkeit Liste Drop D
ich hab das ganz einfach über Daten/Gültigkeit/Liste
angelegt
Hi Jörg,
es gibt da ein paar Probleme, ähem Herausforderungen:smile: Sie sind im Code angedeutet.
Das Ganze ist nur ein Ansatz und müßte ggfs. noch verfeinert werden.
Ein Problem ist, daß die Auswahl eines neuen Wertes kein Ereignis auslöst was man mit Vba auswerten könnte, deshalb habe ich als workaround den Zellenwechsel (SelectionChange-Ereignis) genommen um die Auswahlliste aktualisieren.
Mit Alt-F11 in den VB-Editor wechseln. Falls nicht vorhanden, mit Einfügen–Modul das Modul1 erzeugen. Die Makros in die entsprechenden Codemodule reinkopieren und anpassen.
Makro „Initialisierung“ ist nur gedacht für Tests in einer leeren Datei, dort dann in Tabelle1 aus Symbolleiste-Formular eine Schaltfläche nehmen und das makro Initiaölisierung zuweisen.
Gruß
Reinhard
In das Dokumentenmodul "Tabelle1
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Call Aktualisieren
End Sub
In das Standardmodul "Modul1
Option Explicit
Sub Aktualisieren()
'Wenn man was ausgewählt hat, wird die Auswahlliste dementsprechend angepasst
'Nachteil1: Liste wird nur durch SelectionChange aktualisiert
'Nachteil2: In Xl97 unerklärliche sporadische Excelabstürze bei Klick auf Pfeil, XL2000 stabil:
' Kann aber auch am PC legen.
'Sind die Gültigkeitszellen nicht am Block wie hier in A1:A5 braucht man in XL97 eine UDF die
'alle Zellen mit Gültigkeiten zu einem Bereich zusammenfasst(Stichwort: Union)
'Ab XL2000 kann man Worksheets("Tabelle1").Cells.SpecialCells(xlCellTypeAllValidation) nehmen
Dim Zei2A As Long, Zei2B As Long, Zei1A As Long
Zei1A = Cells(Rows.Count, 1).End(xlUp).Row
With Worksheets("Tabelle2")
.Columns(2).ClearContents
For Zei2A = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
'Es fehlt noch dynamische Anpassung von A1:A5, dafür ist Zei1A angedacht
'Bei unzusammenhängenden Gültigkeitszellen bringt Zei1A natürlich nix
If Application.WorksheetFunction.CountIf(Range("A1:A5"), .Cells(Zei2A, 1)) = 0 Then
Zei2B = Zei2B + 1
.Cells(Zei2B, 2) = .Cells(Zei2A, 1)
End If
Next Zei2A
If Zei2B 0 Then
ActiveWorkbook.Names.Add Name:="Bereich", RefersToR1C1:="=Tabelle2!R1C2:R" & Zei2B & "C2"
Else
ActiveWorkbook.Names.Add Name:="Bereich", RefersToR1C1:=""
End If
End With
End Sub
Sub Initialisierung()
Worksheets("Tabelle1").Activate
With Worksheets("Tabelle2")
.Range("A1:B1").Value = 1
.Range("A1:B20").DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, \_
Step:=1, Stop:=20, Trend:=False
Call Aktualisieren
End With
'With Worksheets("Tabelle1").Cells.SpecialCells(xlCellTypeAllValidation).Validation 'XL2000
With Range("A1:A5").Validation ' XL97
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Bereich"
.IgnoreBlank = False
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Range("A1:A5").ClearContents
Range("A1:A5").Interior.ColorIndex = 34
Range("A8").Select
End Sub