Re: Zeilen vergleichen, doppelte Zeilen wegkopieren
21.01.2003 17:32:28
Steffan
Hallo Walter,teste folgendes Makro (gehört in den Codebereich von 'DieseArbeitsmappe'):
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim wks As Worksheet
Dim wks_alt As Worksheet
Dim i As Integer, j As Integer, k As Integer
Dim startZeile As Integer
Dim zl() As Integer
ReDim zl(0)
'Vereinbarungen
Set wks = Worksheets("Tabelle1")
Set wks_alt = Worksheets("Alt")
startZeile = 2
'Werte vergleichen
For i = startZeile To wks.Cells(65536, 1).End(xlUp).Row - 1
For j = i + 1 To wks.Cells(65536, 1).End(xlUp).Row
If wks.Cells(i, 1).Value = wks.Cells(j, 1).Value And _
wks.Cells(i, 2).Value = wks.Cells(j, 2).Value And _
wks.Cells(i, 5).Value = wks.Cells(j, 5).Value Then
If Not (zl(0) = Empty) Then ReDim Preserve zl(UBound(zl) + 1)
If wks.Cells(i, 11).Value > wks.Cells(j, 11).Value Then _
zl(UBound(zl)) = j Else zl(UBound(zl)) = i
End If
Next j
Next i
'überprüfen ob Zeile mehrfach vorkommt
'wichtig bei mehr als zwei übereinstimmenden Einträgen
For i = 0 To UBound(zl) - 1
For j = i + 1 To UBound(zl)
If zl(i) = zl(j) Then
For k = j To UBound(zl)
If k < UBound(zl) Then zl(k) = zl(j + 1) Else zl(k) = 0
Next k
End If
Next j
Next i
On Error GoTo ex 'falls keine Dopplungen gefunden wurden
If zl(UBound(zl)) = 0 Then ReDim Preserve zl(UBound(zl) - 1)
'Zeilen Verschieben
For i = UBound(zl) To 0 Step -1
wks.Rows(zl(i)).Cut _
Destination:=wks_alt.Cells(wks_alt.Cells(65536, 1).End(xlUp).Row + 1, 1)
wks.Rows(zl(i)).Delete
Next i
ex:
End Sub
Ggf. musst Du die Namen der Tabellenblätter bei Set ... noch anpassen. Außerdem bin ich davon ausgegangen, dass Du vor der Liste noch eine Kopf hast und die Liste erst in Zeile 2 losgeht. Falls nicht musst Du noch 'startZeile' auf Deinen Wert ändern.
Das Makro wird immer automatisch ausgeführt, wenn Du die Datei speicherst.
Steffan.