Markierte Datensätze kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Makro1() Dim loLetzte As Long Application.ScreenUpdating = False With Worksheets("Tabelle1") .Range("$A$1:$C$" & .Cells(.Rows.Count, "A").End(xlUp).Row).AutoFilter Field:=1, Criteria1:= _ "" With .AutoFilter.Range .Offset(1).Resize(.Rows.Count - 1).Copy End With With Worksheets("Tabelle2") loLetzte = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row If .Cells(1, "A") = "" Then loLetzte = 1 .Cells(loLetzte, "A").PasteSpecial Paste:=xlPasteValues End With .Range("A1").AutoFilter End With Application.CutCopyMode = False End Sub

Option Explicit Sub Makro1() Dim loLetzte As Long, loZeilen As Long, boTreffer As Boolean Application.ScreenUpdating = False With Worksheets("Tabelle1") If WorksheetFunction.CountA(.Columns("A")) - 1 > 0 Then boTreffer = True .Range("$A$1:$C$" & .Cells(.Rows.Count, "A").End(xlUp).Row).AutoFilter Field:=1, _ Criteria1:="" .AutoFilter.Range.Offset(, 1).Copy With Worksheets("Tabelle2") loLetzte = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row If .Cells(1, "A") = "" Then loLetzte = 1 .Cells(loLetzte, "A").PasteSpecial Paste:=xlPasteValues End With loZeilen = .Range("$A$1:$A$" & .Cells(.Rows.Count, "A").End(xlUp).Row) _ .SpecialCells(xlCellTypeVisible).Count - 1 .Range("A1").AutoFilter End If End With Application.CutCopyMode = False If boTreffer Then MsgBox "Es wurden " & loZeilen & " Zeilen kopiert." Else MsgBox "Es sind keine Zellen in Spalte A markiert." & vbLf & "Es wurde nichts kopiert." End If End Sub

Hi
wenn die nicht markierten Zellen wirklich leer sind, brauchst du keinen Filter.
dann kannst du die Zellen in Spalte A mit einem "x" oder auch "s" über Start - Bearbeiten - Suchen und Auswählen - Inhalte - Constanten - Texte gezielt markieren und kopieren
geht in VBA so (vollständiger Code incl Auswählen, kopieren und einfügen):

Columns(1).SpecialCells(xlcelltypeconstants).EntireRow.Copy Destination:=Sheets("anderesBlatt").Cells(1, 1)

fertig!
wenn das bei sehr großen Datenmengen noch nicht schnell genug ist, könnte man vorab sortieren, so dass alle zu kopierenden Zellen einen Lückenlosen block bilden.

ActiveSheet.UsedRange.Sort Key1:=Cells(1, 1), order1:=xlascending, header:=xlguess
Columns(1).SpecialCells(xlcelltypeconstants).EntireRow.Copy Destination:=Sheets("anderesBlatt").Cells(1, 1)

Gruß Daniel

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread