AW: Duplikate zusammenfassen - Zusatzfragen
12.04.2013 15:59:14
fcs
Hallo Andreas,
ich hab das Makro mal in die Richtung angepasst.
Da einfacher zu handhaben werden in der neuen Tabelle temporär 2 Hilfsspalten eingefügt.
Im Makro muss dann weniger gerechnet werden.
Gruß
Franz
'Makro in einem Allgemeinen Modul
Sub DatenAufbereiten_Neu()
If MsgBox("Doppelte Einträge im aktiven Blatt aufbereiten?", _
vbQuestion + vbOKCancel, "Doppelte Entfernen") = vbCancel Then Exit Sub
Dim wksNeu As Worksheet, wksQuelle As Worksheet
Dim arrData As Variant, arrErledigt() As Boolean, arrDoNotDelete() As Boolean
Dim varTyp As Variant, Zeile As Long, Zeile1 As Long
'Tabelle mit den Quelldaten setzen
Set wksQuelle = ActiveSheet
'neue Zieltabelle anlegen
Set wksNeu = ActiveWorkbook.Worksheets.Add(after:=wksQuelle)
'Daten in Zieltabelle kopieren
wksQuelle.Range("A:J").Copy Destination:=wksNeu.Range("A:J")
'Daten zur Bearbeitung in Daten-Array einlesen
With wksNeu
Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row
'Hilfsspalten mit Datum+Zeit für Start und Ende in Excelformat erstellen
.Cells(1, 11) = "Start-Datum-Zeit"
.Cells(1, 12) = "Ende-Datum-Zeit"
With .Range(.Cells(2, 11), .Cells(Zeile, 12))
.FormulaR1C1 = "=DATEVALUE(RC[-4])+RC[-2]"
.Calculate
.Value = .Value
.NumberFormat = "DD.MM.YYYY hh:mm"
End With
'Daten nach Typ und Daten in Hilfsspalten (Start, Ende) sortieren
With .Range(.Cells(1, 1), .Cells(Zeile, 12))
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, _
Key2:=.Cells(1, 11), Order2:=xlAscending, _
Key3:=.Cells(1, 12), Order3:=xlAscending, Header:=xlYes
End With
'Daten in Array einlesen
arrData = .Range(.Cells(1, 1), .Cells(Zeile, 12))
'Hilfsarrays anlegen
ReDim arrDoNotDelete(1 To Zeile), arrErledigt(1 To Zeile)
End With
For Zeile = 2 To Zeile
If arrErledigt(Zeile) = False Then
arrErledigt(Zeile) = True
arrDoNotDelete(Zeile) = True
varTyp = arrData(Zeile, 1)
'Typ in Zeilen bis zum Ende der Liste vergleichen
For Zeile1 = Zeile + 1 To UBound(arrErledigt)
If varTyp = arrData(Zeile1, 1) Then
'Start-Datum/Zeiten mit Ende der vorherigen Zeile vergleichen
If arrData(Zeile1, 11)