AW: Bereich für Serienbrief kopieren und löschen
19.01.2009 16:48:30
fcs
Hallo Masureu,
hier mein Vorschlag
Gruß
Franz
Sub ZeilenBereinigen()
Dim wks As Worksheet, lngZeile As Long, LastRow As Long
Dim varVorgesetzt, lngZeile2 As Long, spalte As Long
Set wks = ActiveSheet
Application.ScreenUpdating = False
With wks
LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
For lngZeile = 2 To LastRow
If Not IsEmpty(.Cells(lngZeile, 6)) Then
spalte = 9 '1.Einfüge-Spalte
'Diese und die nächste Zeile wieder löschen, wenn "nur" die Inhalte aus _
den Zeilen mit nachfolgendem gleichen Vorgesetzten kopiert werden sollen.
.Range(.Cells(lngZeile2, 4), .Cells(lngZeile2, 5)).Copy _
Destination:=.Cells(lngZeile, spalte)
spalte = spalte + 2
varVorgesetz = .Cells(lngZeile, 6).Value
For lngZeile2 = lngZeile + 1 To LastRow
If varVorgesetz = .Cells(lngZeile2, 6).Value Then
.Range(.Cells(lngZeile2, 4), .Cells(lngZeile2, 5)).Copy _
Destination:=.Cells(lngZeile, spalte)
.Rows(lngZeile2).Clear
'Spalte für nächsten Kopiervorgang
spalte = spalte + 2
End If
Next
End If
Next
'Leere zeilen Löschen
.Range(.Cells(2, 6), .Cells(LastRow, 6)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete _
shift:=xlShiftUp
End With
Application.ScreenUpdating = True
End Sub