AW: Namenvergabe bedingt
13.01.2010 13:24:39
welga
Hallo nochmals,
markiere Spalte "A" und vergebe einen Gültigkeitsbereich als Liste "=$D:$D".
Dann schreibe das Makro in das entsprechende Tabellenblatt:
Private Sub worksheet_change(ByVal target As Range)
Dim i As Long
Dim ii As Long
Dim a As Long
If Not Intersect(Range(Cells(1, 2), Cells(Cells(1, 2).End(xlDown).Row, 2)), target) Is Nothing _
Then
Application.ScreenUpdating = False
Range(Cells(1, 4), Cells(Cells(1, 4).End(xlDown).Row, 4)).Select
Selection.ClearContents
ii = 1
For i = 1 To Cells(1, 1).End(xlDown).Row
If Cells(i, 2) = "x" Then
ii = ii + 1
Cells(ii, 4) = Cells(i, 1)
End If
Next i
If Cells(2, 4) "" Then
Cells(1, 4).Select
Selection.AutoFilter
Range(Cells(2, 4), Cells(Cells(1, 4).End(xlDown).Row, 4)).Sort Key1:=Range("D2"), Order1:= _
xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.AutoFilter
Selection.Delete shift:=xlUp
For a = Cells(1, 4).End(xlDown).Row To 2 Step -1
If Cells(a, 4) = Cells(a - 1, 4) Then
Cells(a, 4).Select
Selection.Delete shift:=xlUp
End If
Next a
End If
Application.ScreenUpdating = True
End If
End Sub