geht es so?
17.09.2009 19:24:26
Tino
Hallo,
ich hoffe das ich dich richtig verstanden habe.
Sub Beispiel()
Dim Bereich As Range, meAr, meAr1, meAr2(), Dic As Object, ArDic
Dim A As Long, B As Long, C As Long, vRow
Set Dic = CreateObject("Scripting.Dictionary")
'Bereich feststellen ***************************
With Sheets("Tabelle1") 'Tabellennamen anpassen
Set Bereich = .Range("A231", .Cells(.Rows.Count, 1).End(xlUp))
If Not Intersect(Bereich, .Rows("1:230")) Is Nothing Then
MsgBox "Keine Daten ab A231 vorhanden"
Exit Sub
End If
End With
meAr = Bereich
'suche doppelte *********************************
With Application.WorksheetFunction
For A = 1 To Ubound(meAr)
If meAr(A, 1) <> "" Then
If .CountIf(Bereich, meAr(A, 1)) > 1 Then
Dic(meAr(A, 1)) = 0
End If
End If
Next A
End With
A = 0
meAr1 = Range(Bereich, Bereich.Offset(0, 1))
If Dic.Count > 0 Then
C = Dic.Count
Redim Preserve meAr2(1 To C, 1 To 2)
ArDic = Dic.keys
B = 2
End If
'suche die Daten zu den doppelten *************************************
For A = 0 To Dic.Count - 1
vRow = Application.Match(ArDic(A), meAr, 0)
Do While IsNumeric(vRow)
If B > Ubound(meAr2, 2) Then Redim Preserve meAr2(1 To C, 1 To B)
meAr2(A + 1, B) = meAr1(vRow, 2)
meAr2(A + 1, 1) = meAr1(vRow, 1)
meAr(vRow, 1) = ""
vRow = Application.Match(ArDic(A), meAr, 0)
B = B + 1
Loop
B = 2
Next A
'Daten in Tabelle schreiben *******************************************
With Application
.ScreenUpdating = False
.EnableEvents = False
With Sheets("Tabelle2") 'Tabellennamen anpassen
'leer machen für neue Daten eventuell anpassen
.Range("U21", .Cells(.Rows.Count, .Columns.Count)).Value = ""
If A > 0 Then .Range("U21").Resize(Ubound(meAr2), Ubound(meAr2, 2)) = meAr2
End With
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
PS: wieso musst Du sowas machen, wird dies von Dir verlangt obwohl Du es nicht kannst?
Gruß Tino