AW: Doppelte Zeilen löschen
01.10.2012 23:57:14
fcs
Hallo Chris,
hier eine Beispiel-Datei mit einem entsprechenden Makro, das du bezüglich der Spalten, deren Werte in die Zielspalten übertragen werden sollen, noch anpassen musst.
Gruß
Franz
https://www.herber.de/bbs/user/81950.xlsm
Sub BereinigenListe()
Dim wks As Worksheet, arrBox(), arrErledigt() As Boolean
Dim Zeile_L As Long, Zeile As Long, Zeile2 As Long, Treffer As Integer
Dim SpalteZiel1 As Long, SpalteZiel2 As Long, bolGeloescht As Boolean
Dim varBox As Variant
If MsgBox("Liste im aktiven Tabellenblatt bereinigen?", vbQuestion + vbOKCancel, _
"Liste bereinigen") = vbCancel Then Exit Sub
Set wks = ActiveSheet
With wks
'Letzte Datenzeile in Datumsspalte
Zeile_L = .Cells(.Rows.Count, 10).End(xlUp).Row
'1. Daten sortieren
With .Range(.Rows(1), .Rows(Zeile_L))
.Sort key1:=.Range("J1"), Order1:=xlDescending, _
key2:=.Range("I2"), Order2:=xlAscending, Header:=xlYes ' ggf. - anpassen!!
End With
'Daten aus Box-Spalte (I) in Arrayeinlesen
arrBox = .Range(.Cells(1, 9), .Cells(Zeile_L, 9))
'Array für erledigte Zeilen anlegen
ReDim arrErledigt(1 To Zeile_L)
'Zielspalten für doppelte Box-Zeilen vorgeben
SpalteZiel1 = 11 'Spalte K - Zielspalte für 1. Wert - anpassen!!
SpalteZiel2 = 12 'Spalte L - Zielspalte für 2. Wert - anpassen!!
With Application
.ScreenUpdating = False
End With
'Boxen in Spalte I abarbeiten
For Zeile = 2 To Zeile_L - 1
varBox = arrBox(Zeile, 1)
If arrErledigt(Zeile) = False Then
arrErledigt(Zeile) = True
Treffer = 0
'Nach doppelten Einträgen für Box suchen
For Zeile2 = Zeile + 1 To Zeile_L
If arrBox(Zeile2, 1) = varBox Then
If Treffer = 0 Then
'Wert aus Spalte 1 (A) in 1. Zeile übertragen
.Cells(Zeile, SpalteZiel1).Value = .Cells(Zeile2, 1).Text ' ggf. - anpassen!!
'Wert aus Spalte 5 (E) in 1. Zeile übertragen
.Cells(Zeile, SpalteZiel2).Value = .Cells(Zeile2, 5).Text ' ggf. - anpassen!!
Else
With .Cells(Zeile, SpalteZiel1)
.Value = .Value & Chr(10) & wks.Cells(Zeile2, 1).Text ' ggf. - anpassen!!
End With
With .Cells(Zeile, SpalteZiel2)
.Value = .Value & Chr(10) & wks.Cells(Zeile2, 5).Text ' ggf. - anpassen!!
End With
End If
'doppelte Box-Zeile löschen
.Rows(Zeile2).ClearContents
arrErledigt(Zeile2) = True
Treffer = Treffer + 1
bolGeloescht = True
End If
Next Zeile2
End If
Next Zeile
If bolGeloescht = True Then
'Leerzeilen löschen
.Range(.Cells(2, 10), _
.Cells(Zeile_L, 10)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
With Application
.ScreenUpdating = True
End With
End With
Erase arrBox, arrErledigt
End Sub