Mergen von Zeilen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo RS
Anbei der Code fürs Makro!
Gruss
Stefan
Dim wks As Worksheet, lngZeile As Long, LastRow As Long
Dim varM_CSGUID, 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 = 16 '1.Einfüge-Spalte
'Diese und die nächste Zeile wieder löschen, wenn "nur" die Inhalte aus _
den Zeilen mit nachfolgendem gleichen M_CSGUIDen kopiert werden sollen.
.Range(.Cells(lngZeile, 5), .Cells(lngZeile, 6), .Cells(lngZeile, 7)).Copy _
Destination:=.Cells(lngZeile, spalte)
spalte = spalte + 2
varM_CSGUID = .Cells(lngZeile, 6).Value
For lngZeile2 = lngZeile + 1 To LastRow
If varM_CSGUID = .Cells(lngZeile2, 6).Value Then
.Range(.Cells(lngZeile2, 5), .Cells(lngZeile2, 6), .Cells(lngZeile, 7)).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

.Range(.Cells(lngZeile, 5), .Cells(lngZeile, 7)).Copy _ Destination:=.Cells(lngZeile, spalte) spalte = spalte + 2 varM_CSGUID = .Cells(lngZeile, 6).Value For lngZeile2 = lngZeile + 1 To LastRow If varM_CSGUID = .Cells(lngZeile2, 6).Value Then .Range(.Cells(lngZeile2, 5), .Cells(lngZeile, 7)).Copy _ Destination:=.Cells(lngZeile, spalte)

Hallo Erich, hallo RS
Merci! Hat super funktioniert. Habe noch einige Anpassungen vorgenommen und es läuft perfekt.
Nochmals Danke und eine schöne Woche.
Stefan


Sub ZeilenLöschen()
' Makro am 20.01.2009 von A607154 aufgezeichnet
Dim wks As Worksheet, lngZeile As Long, LastRow As Long
Dim varM_CSGUID, 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, 17)) Then
spalte = 20 '1.Einfüge-Spalte
'Diese und die nächste Zeile wieder löschen, wenn "nur" die Inhalte aus _
den Zeilen mit nachfolgendem gleichen M_CSGUIDen kopiert werden sollen.
.Range(.Cells(lngZeile, 5), .Cells(lngZeile, 10)).Copy _
Destination:=.Cells(lngZeile, spalte)
spalte = spalte + 6
varM_CSGUID = .Cells(lngZeile, 17).Value
For lngZeile2 = lngZeile + 1 To LastRow
If varM_CSGUID = .Cells(lngZeile2, 17).Value Then
.Range(.Cells(lngZeile2, 5), .Cells(lngZeile2, 10)).Copy _
Destination:=.Cells(lngZeile, spalte)
.Rows(lngZeile2).Clear
'Spalte für nächsten Kopiervorgang
spalte = spalte + 6
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

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread