Duplikate aus Excel (nicht2007)entfernen

Computer: Software & Programmierung Office Software
1

Hallo allerseids,

ich habe eine Exceltabelle die aus mehreren Sheets besteht. Ich moechte alle diese sheets in einem gesonderten sheet sozusagen einem Mastersheet zusammenfuehren per Makro, dazu habe nach langer zeit mit Google folgenden Code gefunden.

Sub Bereichkopieren()

Dim LetzteZeile As Long
Dim QuellWB As Workbook
Dim ZielWB As Workbook

’ Objektvariablen, die auf die Quellendatei
’ bzw. die Zieldatei zeigen. Für Testzwecke beide=Activeworkbook
’ Variablenbelegung muss angepasst werden.

Set QuellWB = ActiveWorkbook
Set ZielWB = ActiveWorkbook

’ Quelltabelle aktivieren
QuellWB.Sheets(„calibur“).Activate

’ letzte benutze Zeile ermitteln
LetzteZeile = Range(„A65535“).End(xlUp).Row

’ benutzten Bereich kopieren (ab Zeile 2)
Range(„A177“, „R“ & LetzteZeile).Copy

’ Zieltabelle aktivieren
ZielWB.Sheets(„Sheet4“).Activate

’ erste freie Zelle in Spalte A selektieren
Range(„A65535“).End(xlUp).Offset(1, 0).Select

’ Inhalt der Zwischenablage einfügen
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

’ erste freie Zelle in Spalte A selektieren
’ (nur zum Aufräumen)
Range(„A65535“).End(xlUp).Offset(1, 0).Select
End Sub

der funktioniert soweit auch ganz gut (ist zum testen erstmal nur fuer 1sheet). nur kopiert er die Daten halt auch doppelt wenn man ihn doppelt ausfuehrt.

zum entfernen der duplikate habe ich diesen code gefunden und gebastelt:
Sub DoppelteSätzeRauswerfen()
'zuerst sortieren
Columns(„A:A“).Select
Selection.Sort Key1:=Range(„A1“), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'jetzt doppelte Sätze rausschmeißen
Range(„A“).Select
Do Until ActiveRow.Value = ActiveRow.Offset(1, 0)
If ActiveCell.Value = ActiveCell.Offset(1, 0).Value Then
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
End Sub

dieser sucht die Duplikate nun aber nur in der ersten spalte und wenn er eins findet loescht er die ganze zeile. Es soll aber die ganze Zeile ueberprueft werden und nur dann geloescht werden, wenn die komplette Zeile ein duplikat ist. Ich komm da irgendwie nicht weiter, vielleicht gibts hier ja jemanden der ein wenig helfen kann.
P.S. ich habe nicht wirklich VBA kentnisse, also bitte die Antwort fuer dumme : ).

Gruss Danny

2

Hi Danny,

Multiposting in verschiedenen Brettern ist hier nicht gern gesehen, deshalb ist dein gleicher Beitrag im anderen Brett schon im Nirwana.

ich habe eine Exceltabelle die aus mehreren Sheets besteht.
Ich moechte alle diese sheets in einem gesonderten sheet
sozusagen einem Mastersheet zusammenfuehren per Makro, dazu

dieser sucht die Duplikate nun aber nur in der ersten spalte
und wenn er eins findet loescht er die ganze zeile. Es soll
aber die ganze Zeile ueberprueft werden und nur dann geloescht
werden, wenn die komplette Zeile ein duplikat ist. Ich komm da

P.S. ich habe nicht wirklich VBA kentnisse, also bitte die
Antwort fuer dumme : ).

Zum PS, du hast etwas Komplexes vor, daß geht nun mal nicht mit 'nem Dreizeiler:smile:

Wenn im Code ein Fehler auftritt so wird, sofern er beim Zellenvergleich auftrat, die Zeilen- und Spaltennummer gemeldet. So ein Fehler tritt auf wenn in den beiden verglichenen Zellen z.B. „#WERT!“ o.ä. steht.

In ein Standarmodul, z.B. Modul1:

Option Explicit
'
Sub tt()
Dim wksQ As Worksheet, Zei As Long, Spa As Long, Gleich As Boolean, maxSpa As Long
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets("Master").Delete
Application.DisplayAlerts = True
On Error GoTo Fehler
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Master"
With Worksheets("Master")
 For Each wksQ In Worksheets
 If wksQ.Name .Name Then
 Zei = .Range("A" & Rows.Count).End(xlUp).Row
 If Zei = 1 And .Range("A1") = "" Then Zei = 0
 wksQ.UsedRange.Copy Destination:=.Range("A" & Zei + 1)
 End If
 Next wksQ
 maxSpa = .Cells.SpecialCells(xlCellTypeLastCell).Column
 For Spa = maxSpa To 1 Step -1
 .UsedRange.Sort Key1:=.Cells(1, Spa), Order1:=xlAscending, Header:=xlNo, \_
 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
 Next Spa
 For Zei = .Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
 Gleich = True
 For Spa = maxSpa To 1 Step -1
 If .Cells(Zei, Spa).Value .Cells(Zei - 1, Spa).Value Then
 Gleich = False
 Exit For
 End If
 Next Spa
 If Gleich = True Then .Rows(Zei).Delete
 Next Zei
End With
Fehler:
Application.ScreenUpdating = True
If Err.Number 0 Then MsgBox "es trat ein Fehler auf bei Zeile " & Zei & " Spalte" & Spa
End Sub

Gruß
Reinhard