' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub checkDoubleAndDelete()
Dim rngDel As Range
Dim lngRow As Long, lngLast As Long, lngC As Long
Dim vntRet As Variant
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With ActiveSheet
lngLast = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
For lngRow = 2 To lngLast
If Application.CountIf(.Range(.Cells(2, 1), .Cells(lngRow, 1)), .Cells(lngRow, 1)) > 1 Then
vntRet = Application.Match(.Cells(lngRow, 1), .Columns(1), 0)
If IsNumeric(vntRet) Then
lngC = .Cells(vntRet, .Columns.Count).End(xlToLeft).Column + 1
.Range(.Cells(lngRow, 6), .Cells(lngRow, 9)).Copy .Cells(vntRet, lngC)
If rngDel Is Nothing Then
Set rngDel = .Rows(lngRow)
Else
Set rngDel = Union(rngDel, .Rows(lngRow))
End If
End If
End If
Next
End With
If Not rngDel Is Nothing Then rngDel.Delete
ErrExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set rngDel = Nothing
End Sub