Das doch schon mal ein Fortschritt :o)
16.03.2005 15:19:30
Chris
Hi Bert,
Sub test2()
Dim Doppelt()
Dim c As Object
Dim i As Integer, j As Integer
Dim Text As Variant
ReDim Doppelt(2, 1)
i = 1
j = 0
Do
i = i + 1
If Cells(1 + i, 2).Value <> "" Then
Set c = Range("B:B").Find(what:=Cells(1 + i, 2).Value, after:=Cells(1 + i, 2))
If c.Row <> 1 + i Then
' For d = 1 To j
' If Doppelt(2, d) = Cells(1 + i, 2).Value Then
' Exit For
' End If
' Next d
' If d > j Then
j = j + 1
ReDim Preserve Doppelt(2, j)
Doppelt(1, j) = Cells(1 + i, 1).Value
Doppelt(2, j) = Cells(1 + i, 2).Value
' End If
End If
End If
Loop Until Cells(1 + i, 2).Value = ""
If i > 1 Then
For i = 2 To j
If StrComp(Doppelt(2, i), Doppelt(2, i - 1), vbTextCompare) < 0 Then
Text = Doppelt(2, i)
Doppelt(2, i) = Doppelt(2, i - 1)
Doppelt(2, i - 1) = Text
Text = Doppelt(1, i)
Doppelt(1, i) = Doppelt(1, i - 1)
Doppelt(1, i - 1) = Text
i = 1
End If
Next i
End If
Text = ""
'Ab hier dann Ausgabe in Userform
For i = 1 To j
Text = Text & Chr(10) & Doppelt(2, i) & " (" & Doppelt(1, i) & ")"
Next i
MsgBox Text
Der Teil mit den Hochkommas in der Mitte ist somit überflüssig, da wird geprüft, ob der Name schon mal im Array vorkommt und nur aufgenommen wenn nicht. Ohne diesen Teil kommen alle doppelten Namen so oft vor, wie sie auch drinnen sind.
Gruss
Chris
End Sub