Zeilen selektiv kopieren und löschen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub test() Dim lngRow As Long, lngA As Long Dim i As Long lngRow = Cells(Rows.Count, 1).End(xlUp).Row With Application .ScreenUpdating = False For lngA = lngRow To 1 Step -1 If "12;14;28;30;39" Like "*" & Cells(lngA, 1) & "*" Then i = i + 1 Rows(Cells(lngA, 1).Row).Copy Sheets("Tabelle2").Rows(i) Rows(Cells(lngA, 1).Row).Delete End If Next lngA .ScreenUpdating = True End With End Sub

Sub tt() Dim i As Long Application.ScreenUpdating = False With Sheets(1) For i = .Cells(Rows.Count, 1).End(xlUp) To 1 Step -1 Select Case .Cells(i, 1) Case 12, 14, 28, 30, 39 Cells(i, 1).Resize(, 4).Copy _ Sheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) .Rows(i).Delete End Select Next End With Application.ScreenUpdating = True End Sub

Option Explicit Sub test() Dim lngRow As Long, lngA As Long Dim i As Long lngRow = Cells(Rows.Count, 1).End(xlUp).Row With Application .ScreenUpdating = False For lngA = lngRow To 1 Step -1 Select Case Cells(lngA, 1) Case 12, 14, 28, 30, 39 i = i + 1 Rows(Cells(lngA, 1).Row).Copy Sheets("Tabelle2").Rows(i) Rows(Cells(lngA, 1).Row).Delete End Select Next lngA .ScreenUpdating = True End With End Sub

Option Explicit Sub Test2() Dim tempBereich As Range, Bereich As Range Application.ScreenUpdating = False Set tempBereich = Range("A1", Cells(Rows.Count, 1).End(xlUp)).Offset(0, 4) tempBereich.FormulaR1C1 = "=IF(OR(RC1=12,RC1=14,RC1=28,RC1=30,RC1=39),TRUE,"""")" Set Bereich = tempBereich.SpecialCells(xlCellTypeFormulas, 4).EntireRow tempBereich.Clear Bereich.Copy Sheets("Tabelle2").Range("A1") Bereich.Delete Application.ScreenUpdating = True End Sub

Hallo.
Probier es mal so:


Sub copyAndDelete()
Dim i As Long
Dim schreibZeile As Long
Dim quellWsh As Worksheet
Dim zielWsh As Worksheet
Dim copyRows() As Long
Application.ScreenUpdating = False
Set quellWsh = ActiveSheet
Set zielWsh = ThisWorkbook.Sheets.Add(, ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ReDim copyRows(0)
' Zeilen finden und kopieren
For i = 1 To quellWsh.Cells(Rows.Count, 1).End(xlUp).Row
Select Case quellWsh.Cells(i, 1).Value
Case 12, 14, 28, 30, 39
schreibZeile = schreibZeile + 1
quellWsh.Rows(i).Copy zielWsh.Cells(schreibZeile, 1)
ReDim Preserve copyRows(UBound(copyRows) + 1)
copyRows(UBound(copyRows)) = i
End Select
Next
' Falls etwas gefunden
If UBound(copyRows) > 0 Then
' Zeilen löschen
For i = UBound(copyRows) To 1 Step -1
quellWsh.Rows(copyRows(i)).Delete
Next
' Ansonsten das angelegte Sheet wieder weg
Else
Application.DisplayAlerts = False
zielWsh.Delete
Application.DisplayAlerts = True
quellWsh.Activate
End If
Application.ScreenUpdating = True
End Sub

Bei Fragen einfach nochmal melden.
Gruss, Jogy

Sub copyAndDelete2() Dim i As Long Dim quellWsh As Worksheet Dim zielWsh As Worksheet Application.ScreenUpdating = False Set quellWsh = ActiveSheet Set zielWsh = ThisWorkbook.Sheets.Add(, ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) ' Zeilen finden, kopieren und löschen For i = quellWsh.Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1 Select Case quellWsh.Cells(i, 1).Value Case 12, 14, 28, 30, 39 zielWsh.Rows(1).Insert shift:=xlDown quellWsh.Rows(i).Copy zielWsh.Cells(1, 1) quellWsh.Rows(i).Delete End Select Next ' Falls nichts gefunden, das neue Sheet wieder weg If zielWsh.UsedRange.Address = "$A$1" Then Application.DisplayAlerts = False zielWsh.Delete Application.DisplayAlerts = True quellWsh.Activate End If Application.ScreenUpdating = True End Sub

Sub tt() Dim i As Long, rngCopy As Range Application.ScreenUpdating = False With Sheets(1) For i = .Cells(Rows.Count, 1).End(xlUp) To 1 Step -1 Select Case .Cells(i, 1) Case 12, 14, 28, 30, 39 If rngCopy Is Nothing Then Set rngCopy = .Cells(i, 1) Else Set rngCopy = Union(rngCopy, .Cells(i, 1)) End If End Select Next End With With rngCopy.EntireRow .Copy Sheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) .Delete End With Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

Zeilen selektiv kopieren und löschen

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeilen selektiv kopieren und löschen

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread