Herbers Excel-Forum - das Archiv

Option Explicit

Sub ZeilenKopieren()
   Dim wsQuelle As Worksheet, wsZiel As Worksheet
   Dim Bereich As Range
   Dim Startzeile As Byte, Endzeile&, Zeile&
   Dim Startspalte As Byte, Endspalte As Byte, Spalte As Byte
   Set wsQuelle = Worksheets("Tabelle1")
   Set wsZiel = Worksheets("Tabelle2")
   Set Bereich = wsQuelle.UsedRange
   Startzeile = 1
   Endzeile = Bereich.Rows.Count
   Startspalte = 1
   Endspalte = Bereich.Columns.Count
   Application.ScreenUpdating = False
   
   With wsZiel
      .Activate
      .UsedRange.Clear
      .Cells(1, 1).Activate
   End With
      
   wsQuelle.Activate
      
   For Zeile = Startzeile To Endzeile
      For Spalte = Startspalte To Endspalte
         If Cells(Zeile, Spalte).Interior.ColorIndex = 3 Then
            Rows(Zeile).EntireRow.Copy
               With wsZiel
                  .Activate
                  .Paste
                  .Application.CutCopyMode = False
               End With
            ActiveCell.Offset(1, 0).Activate
            wsQuelle.Activate
            Exit For
         End If
      Next Spalte
   Next Zeile
   
   Application.ScreenUpdating = True
End Sub