Zusammenfassen ohne Duplicate über mehrere Blätter

Sub Zusammenfassen()
Dim iRow As Integer, iCol As Integer, iAct As Integer
Dim iCountC As Integer, iRowLT As Integer, iRowLS As Integer
iCol = 1
Do Until IsEmpty(Cells(1, iCol))
For iAct = iCol + 1 To WorksheetFunction.CountA(Rows(1))
If Cells(1, iCol).Value = Cells(1, iAct).Value And _
WorksheetFunction.CountA(Columns(iCol)) > 1 Then
iRowLS = Cells(Rows.Count, iAct).End(xlUp).Row
iRowLT = Cells(Rows.Count, iCol).End(xlUp).Row + 1
Range(Cells(2, iAct), Cells(iRowLS, iAct)).Cut _
Cells(iRowLT, iCol)
End If
Next iAct
iCol = iCol + 1
Loop
Application.CutCopyMode = False
For iCol = Range("IV1").End(xlToLeft).Column To 1 Step -1
If WorksheetFunction.CountA(Columns(iCol)) = 1 Then
Columns(iCol).Delete
End If
Next iCol
End Sub