Danke!!
Option Explicit
Option Base 1
Private InputRange As Range
Private OneRow As Range
Private OneCell As Range
Private OneRowArr() As Variant, OneRowArrIndex As Integer
Private RowsToDeleteArr() As Variant, RowsToDeleteArrIndex As Integer
Public Sub DoppelteZeilenLoschen()
Set InputRange = ActiveCell.CurrentRegion
RowsToDeleteArrIndex = 1
ReDim RowsToDeleteArr(RowsToDeleteArrIndex)
For Each OneRow In InputRange.Rows
OneRowArrIndex = 0
For Each OneCell In OneRow.Cells
OneRowArrIndex = OneRowArrIndex + 1
ReDim Preserve OneRowArr(OneRowArrIndex)
OneRowArr(OneRowArrIndex) = OneCell.Value
Next OneCell
RowsToDelete OneRowArr(), OneRow.Row
Next OneRow
For RowsToDeleteArrIndex = 1 To UBound(RowsToDeleteArr)
If RowsToDeleteArr(RowsToDeleteArrIndex) <> "" Then _
Rows(RowsToDeleteArr(RowsToDeleteArrIndex)).Interior.ColorIndex = 3
Next RowsToDeleteArrIndex
End Sub
Public Sub RowsToDelete(ByRef aOneRowArr() As Variant, _
ByRef ActualRowNumber As Integer)
For Each OneRow In InputRange.Rows
OneRowArrIndex = 0
For Each OneCell In OneRow.Cells
OneRowArrIndex = OneRowArrIndex + 1
If OneCell.Value <> aOneRowArr(OneRowArrIndex) Or _
OneCell.Row = ActualRowNumber Or _
IsInRowsToDeleteArr(ActualRowNumber) = True Then
GoTo NextRow
End If
Next OneCell
RowsToDeleteArrIndex = RowsToDeleteArrIndex + 1
ReDim Preserve RowsToDeleteArr(RowsToDeleteArrIndex)
RowsToDeleteArr(RowsToDeleteArrIndex) = OneRow.Row
NextRow:
Next OneRow
End Sub
Public Function IsInRowsToDeleteArr(ByRef aActualRow As Integer) As Boolean
Dim index As Integer
IsInRowsToDeleteArr = False
For index = 1 To UBound(RowsToDeleteArr)
If RowsToDeleteArr(index) = aActualRow Then
IsInRowsToDeleteArr = True
Exit Function
End If
Next index
End Function
schaue mal hier
https://www.herber.de/forum/messages/188603.html
Gruß Hajo
Option Explicit
Option Base 1
Private InputRange As Range, FirstRow As Integer, LastRow As Integer, iRow As Integer
Private OneRow As Range
Private OneCell As Range
Private OneRowArr() As Variant, OneRowArrIndex As Integer
Private RowsToDeleteArr() As Variant, RowsToDeleteArrIndex As Integer
Public Sub DoppelteZeilenLoschen()
Set InputRange = ActiveCell.CurrentRegion
FirstRow = InputRange.Rows(1).Row
LastRow = InputRange.Rows(1).Row + InputRange.Rows.Count - 1
RowsToDeleteArrIndex = 1
ReDim RowsToDeleteArr(RowsToDeleteArrIndex)
For Each OneRow In InputRange.Rows
OneRowArrIndex = 0
For Each OneCell In OneRow.Cells
OneRowArrIndex = OneRowArrIndex + 1
ReDim Preserve OneRowArr(OneRowArrIndex)
OneRowArr(OneRowArrIndex) = OneCell.Value
Next OneCell
RowsToDelete OneRowArr(), OneRow.Row
Next OneRow
For RowsToDeleteArrIndex = 1 To UBound(RowsToDeleteArr)
If RowsToDeleteArr(RowsToDeleteArrIndex) <> "" Then _
Rows(RowsToDeleteArr(RowsToDeleteArrIndex)).Interior.ColorIndex = 3
Next RowsToDeleteArrIndex
iRow = FirstRow
Do
If Rows(iRow).Interior.ColorIndex = 3 Then
Rows(iRow).Delete
LastRow = LastRow - 1
If Rows(iRow).Interior.ColorIndex <> 3 Then iRow = iRow + 1
Else
iRow = iRow + 1
End If
Loop While iRow <= LastRow
End Sub
Public Sub RowsToDelete(ByRef aOneRowArr() As Variant, _
ByRef ActualRowNumber As Integer)
For Each OneRow In InputRange.Rows
OneRowArrIndex = 0
For Each OneCell In OneRow.Cells
OneRowArrIndex = OneRowArrIndex + 1
If OneCell.Value <> aOneRowArr(OneRowArrIndex) Or _
OneCell.Row = ActualRowNumber Or _
IsInRowsToDeleteArr(ActualRowNumber) = True Then
GoTo NextRow
End If
Next OneCell
RowsToDeleteArrIndex = RowsToDeleteArrIndex + 1
ReDim Preserve RowsToDeleteArr(RowsToDeleteArrIndex)
RowsToDeleteArr(RowsToDeleteArrIndex) = OneRow.Row
NextRow:
Next OneRow
End Sub
Public Function IsInRowsToDeleteArr(ByRef aActualRow As Integer) As Boolean
Dim index As Integer
IsInRowsToDeleteArr = False
For index = 1 To UBound(RowsToDeleteArr)
If RowsToDeleteArr(index) = aActualRow Then
IsInRowsToDeleteArr = True
Exit Function
End If
Next index
End Function