wie kann ich in einer Tabelle, die nach Spalte A sortiert ist (Zahlformat) alle Zeilen bei denen der Inhalt der Spalte A nur einmal vorkommt in ein neues Arbeitsblatt verschieben lassen.
Freue mich über jegliche Hilfe
Sub Kerstin_Hu()
Dim i As Long, laR As Long
ThisWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
Sheets("Herkunft beides").Select
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(i, 1).Value <> Cells(i - 1, 1).Value And _
Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
With Sheets(Sheets.Count)
laR = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Range("A" & laR & ":F" & laR).Value = _
Range("A" & i & ":F" & i).Value
Rows(i).Delete Shift:=xlUp
End With
End If
Next i
With Sheets(Sheets.Count)
.Range("A1:F" & laR).Sort Key1:=.Range("A1"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End With
End Sub
Sub Kerstin_Hu()
Dim sT1 As String, sT2 As String
Dim i As Long, laR As Long
Application.ScreenUpdating = False
ThisWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
Sheets("Herkunft beides").Select
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(i, 1).Value <> Cells(i - 1, 1).Value And _
Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
With Sheets(Sheets.Count)
laR = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Range("A" & laR & ":F" & laR).Value = _
Range("A" & i & ":F" & i).Value
Rows(i).Delete Shift:=xlUp
End With
End If
Next i
Cells.Copy
With Sheets(Sheets.Count)
.Cells.PasteSpecial Paste:=xlPasteFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
.Range("A1:F" & laR).Sort Key1:=.Range("A1"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End With
laR = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:F" & laR).Sort Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
For i = laR To 2 Step -1
sT1 = Cells(i, 1).Text & Cells(i, 2).Text
sT2 = Cells(i - 1, 1).Text & Cells(i - 1, 2).Text
If sT1 = sT2 Then Rows(i).Delete Shift:=xlUp
Next i
Application.ScreenUpdating = True
End Sub
Sub Kerstin_Hu()
Dim sT1 As String, sT2 As String
Dim i As Long, laR As Long
Application.ScreenUpdating = False
ThisWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
Sheets("Herkunft beides").Select
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(i, 1).Value <> Cells(i - 1, 1).Value And _
Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
With Sheets(Sheets.Count)
laR = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Range("A" & laR & ":F" & laR).Value = _
Range("A" & i & ":F" & i).Value
Rows(i).Delete Shift:=xlUp
End With
End If
Next i
Cells.Copy
With Sheets(Sheets.Count)
.Cells.PasteSpecial Paste:=xlPasteFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
.Range("A1:F" & laR).Sort Key1:=.Range("A1"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End With
laR = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:F" & laR).Sort Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
For i = laR To 2 Step -1
sT1 = Cells(i, 1).Text & Cells(i, 2).Text
sT2 = Cells(i - 1, 1).Text & Cells(i - 1, 2).Text
If sT1 = sT2 Then
Cells(i - 1, 1).Interior.ColorIndex = 46
Rows(i).Delete Shift:=xlUp
ElseIf Cells(i, 1).Interior.ColorIndex = 46 Then
Rows(i).Delete Shift:=xlUp
End If
Next i
Application.ScreenUpdating = True
End Sub
Sub Kerstin_Hu()
Dim sT1 As String, sT2 As String
Dim i As Long, laR As Long
Application.ScreenUpdating = False
ThisWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
Sheets("Herkunft beides").Select
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(i, 1).Value <> Cells(i - 1, 1).Value And _
Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
With Sheets(Sheets.Count)
laR = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Range("A" & laR & ":F" & laR).Value = _
Range("A" & i & ":F" & i).Value
Rows(i).Delete Shift:=xlUp
End With
End If
Next i
Cells.Copy
With Sheets(Sheets.Count)
.Cells.PasteSpecial Paste:=xlPasteFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
.Range("A1:F" & laR).Sort Key1:=.Range("A1"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With
laR = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:F" & laR).Sort Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
For i = laR To 2 Step -1
sT1 = Cells(i, 1).Text & Cells(i, 2).Text
sT2 = Cells(i - 1, 1).Text & Cells(i - 1, 2).Text
If sT1 = sT2 Then
Cells(i - 1, 1).Interior.ColorIndex = 46
Rows(i).Delete Shift:=xlUp
ElseIf Cells(i, 1).Interior.ColorIndex = 46 Then
Rows(i).Delete Shift:=xlUp
End If
Next i
Application.ScreenUpdating = True
End Sub