AW: Gültigkeitsprüfung stimmt nach Speichern nicht meh
20.02.2010 09:00:51
Josef
Hallo Sonja,
achte darauf, welcher Codeteil wohin gehört und mache im Code die notwendigen Anpassungen (siehe Kommentare).
' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub Workbook_Open()
addValidation
End Sub
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Const cstrFile As String = "C:\Ordner\Mappe2.xls" 'Dateiname - Anpassen!
Const cstrTab As String = "Namenliste" 'Tabellenname - Anpassen!
Const cstrRange As String = "A39:A147" 'Zellbereich - Anpassen!
Sub addValidation()
Dim objWb As Workbook, vntList As Variant
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
If Dir(cstrFile) <> "" Then
Set objWb = Workbooks.Open(cstrFile)
vntList = UniqueList(objWb.Sheets(cstrTab).Range(cstrRange), True)
objWb.Close False
'Tabellenname und Bereich der Gültigkeit - Anpassen!
With ThisWorkbook.Sheets("Tabelle1").Range("A1:A25")
.Validation.Delete
.Validation.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=Join(vntList, ",")
End With
End If
ErrExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set objWb = Nothing
End Sub
Private Function UniqueList(Matrix As Range, Optional Sorted As Boolean = True) As Variant
Dim objDic As Object, rng As Range, varTmp() As Variant
Set objDic = CreateObject("Scripting.Dictionary")
For Each rng In Matrix
If rng.Value <> "" Then objDic(rng.Value) = 0
Next
varTmp = objDic.keys
If Sorted Then QuickSort varTmp
UniqueList = varTmp
Set objDic = Nothing
End Function
Private Sub QuickSort(data() As Variant, Optional UG, Optional OG)
Dim P1&, P2&, T1 As Variant, T2 As Variant
UG = IIf(IsMissing(UG), LBound(data), UG)
OG = IIf(IsMissing(OG), UBound(data), OG)
P1 = UG
P2 = OG
T1 = data((P1 + P2) / 2)
Do
Do While (data(P1) < T1)
P1 = P1 + 1
Loop
Do While (data(P2) > T1)
P2 = P2 - 1
Loop
If P1 <= P2 Then
T2 = data(P1)
data(P1) = data(P2)
data(P2) = T2
P1 = P1 + 1
P2 = P2 - 1
End If
Loop Until (P1 > P2)
If UG < P2 Then QuickSort data, UG, P2
If P1 < OG Then QuickSort data, P1, OG
End Sub
Gruß Sepp