AW: habe Lösung......................mT.
23.11.2006 11:23:44
HermannZ
hallo Franz;
habe eine zufriedenstellende Lösung gefunden,und nochmal Danke für deine Unterstützung dadurch habe ich das jetzt auch etwas mehr begriffen.
Sub OhneDuplikate1()
Dim zl As Long, sp As Long, azl As Long, bereich As Range, bereich1 As Range
Dim fsp As Long, lsp As Long, asp As Long, lzl As Long
Dim intText As Integer
Set bereich = Application.InputBox("Bitte einen Bereich markieren", , , , , , , 8)
Set bereich1 = Application.InputBox("Bitte erste Zelle des Ausgabebereichs markieren", , , , , , , 8)
lzl = bereich.Rows.Count + bereich.Row - 1
fsp = bereich.Column
lsp = bereich.Columns.Count + bereich.Column - 1
asp = bereich1.Column
azl = bereich1.Row
For sp = fsp To lsp
For zl = bereich.Row To lzl
If Cells(zl, sp) <> "" Then
If WorksheetFunction.CountIf(bereich, Cells(zl, sp)) > 1 Then
If WorksheetFunction.CountIf(Columns(asp), Cells(zl, sp)) = 0 Then
Cells(azl, asp) = Cells(zl, sp)
azl = azl + 1
End If
End If
End If
Next
Next
'Sortieren Ergebnis
Range(Cells(bereich1.Row, asp), Cells(65536, asp)).Sort key1:=Cells(azl, asp), _
Order1:=xlAscending, Header:=xlNo
End Sub
Gruss hermann