AW: Hilfe ! (@Renée, Franz oder Rudi)
23.05.2008 15:46:00
fcs
Hallo Markus,
ich bei mir eine Löschroutine ausgegraben und an deine Tabelle angepasst.
In deiner Beispielmappe waren keine doppelten Sätze enthalten. Spalte A und C oft identisch aber F dann verschieden.
Vor dem 1. Lauf des Makros Sicherheitskopie machen!!!
Die Löschaktion kann nicht rückgängig gmacht werden!!!!!
Kopiere das Makro am besten in ein separates Modul.
Das Makro bearbeitet jeweils die aktive Tabelle.
Gruß
Franz
Option Explicit
Sub DoppelteLoeschen_Download()
'MAkro zum Eleminieren von Daten zeilen im Blatt Download_SQ01, die in den _
Splaten A, S und F identisch
Dim varMeldung As Variant, wks As Worksheet
Set wks = ActiveSheet
With wks
'Bereich Spalte A bis Spalte L, Zeile 2 bis letzte Zeile
varMeldung = DuplikateLoeschen(objWks:=wks, strBereich:=.Range(.Cells(2, 1), _
.Cells(.Rows.Count, 1).End(xlUp).Offset(0, 11)).Address, _
bolSort:=True, bolMeldung:=True)
If varMeldung = "" Then
'do nothing
Else
MsgBox varMeldung
End If
End With
End Sub
Public Function DuplikateLoeschen(objWks As Worksheet, strBereich As String, _
Optional bolSort As Boolean = False, _
Optional bolMeldung As Boolean = False) As String
'Tabellen-Zeilen die identisch in Spalte A, C und F sind des Bereiches entfernen
'objWks = Tabellenblatt in dem die Doppelten entfernt werden sollen
'strBereich = Bereichsname oder Zellbereich
'bolSort = True: Sortierung der Daten in der Tabelle bleibt erhalten _
False: Tabelle wird nach der Duplikate-Spalte sortiert
'bolMeldung = True: Meldung über Anzahl gelöschte Zeilen wird angezeigt _
False: Meldung wird nicht angezeigt
Dim rngData As Range
Dim rngSort As Range
Dim rngVergleich As Range
Dim nRowsDel As Long
Application.ScreenUpdating = False
On Error GoTo Fehler
With objWks
'Duplikate-Bereich setzen
Set rngData = .Range(strBereich)
If rngData.Rows.Count = 1 Then
MsgBox "Der Datenbeich enthält nur eine Zeile, keine Doppelten möglich."
GoTo Beenden
ElseIf Application.WorksheetFunction.CountA(rngData.Columns(1)) = 0 Then
MsgBox "Der Datenbereich enthält keine Daten!"
GoTo Beenden
End If
'2 Hilfs-Spalten links von Spalte A einfügen
.Range(.Columns(1), Columns(2)).Insert shift:=xlShiftToRight
End With
If bolSort = True Then
Set rngSort = rngData.Columns(1).Offset(0, -rngData.Column + 1)
'Formel für Zeilenummer in Sotierbereich einfügen
rngSort.Formula = "=ROW()"
'Formel duch Werte ersetzen
rngSort.Value = rngSort.Value
End If
'Tabellen-Zeilen nach Duplikatespalten 1., 3., 6. Spalte sortieren
With rngData
.EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, _
key1:=.Cells(1, 3), order1:=xlAscending, _
key1:=.Cells(1, 6), order1:=xlAscending, header:=xlNo
End With
'Bereich in 2. Spalte für Vergleich definieren
Set rngVergleich = rngData.Columns(1).Offset(0, -rngData.Column + 2)
'Formel für Zeilenvergleich einfügen, dann durch Werte ersetzen
With rngVergleich
'Vergleichformel für die 3 Zellen in den beiden Zeilen
.FormulaR1C1 = "=IF(RC[1]&RC[3]&RC[6]=R[-1]C[1]&R[-1]C[3]&R[-1]C[6],TRUE,RC[-1])"
.Value = .Value
'Anzahl Zeilen vor dem Löschen
nRowsDel = objWks.Cells(objWks.Rows.Count, .Column).End(xlUp).Row
'Zeilen mit Wert WAHR in Vergleichsspalte löschen
'Tabellenzeilen nach Vergleichsspalte sortieren (Sortiert zu löschende ans Ende)
.EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlNo
'Letzten Eintrag in Vergleichsspalte prüfen und ggf. Zeilen löschen
If objWks.Cells(objWks.Rows.Count, .Column).End(xlUp).Value = True Then
.SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete shift:=xlShiftUp
End If
'Anzahl gelöschte Zeilen
nRowsDel = nRowsDel - objWks.Cells(objWks.Rows.Count, .Column).End(xlUp).Row
End With
If bolSort = True Then
'Tabellen-Zeilen wieder in alte Reihenfolge sortieren
With rngSort
.EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlNo
End With
Else
'Tabellen-Zeilen nach Duplikate-Spalte sortieren
With rngData
.EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlNo
End With
End If
'Hilfsspalten wieder löschen
With objWks
.Range(.Columns(1), .Columns(2)).Delete shift:=xlShiftToLeft
End With
If bolMeldung = True Then
MsgBox Prompt:="Es wurden " & nRowsDel & " doppelte Datensätze gelöscht!", _
Buttons:=vbOKOnly + vbInformation, _
Title:="Doppelte Datensätze löschen"
End If
DuplikateLoeschen = ""
GoTo Beenden
Fehler:
DuplikateLoeschen = "Fehler bei Ausführung der Prozedur ""DuplikateLöschen""" _
& vbLf & vbLf _
& "Fehler Nummer: " & Err.Number & vbLf & Err.Description
If Not rngSort Is Nothing Then
'Hilfsspalten wieder löschen
With objWks
.Range(.Columns(1), .Columns(2)).Delete shift:=xlShiftToLeft
End With
End If
Beenden:
Set rngData = Nothing: Set rngSort = Nothing: Set rngVergleich = Nothing
Application.ScreenUpdating = True
End Function