Nur bestimmte Werte in neues Tabellenblatt kopieren

Option Explicit


Sub Übertrag()

 Application.ScreenUpdating = False

' Tabelle: Quelle
' Tabelle Ziel: Ziel
' Kopiert die SoD-Konflikte von Quelle in das Dashboard
'

Const Blatt1 = "Quelle"           ' Source
Const Blatt2 = "Ziel" ' Ziel
Dim I As Integer
Dim iAnz As Integer
Dim letzte As Long

    ' ermittelt die letzte befüllte Zelle
    Worksheets("Ziel").Activate
    letzte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
    ' ermittelt die letzte befüllte Zelle
    
    ' Markiert und löscht den Bereich
    Worksheets("Ziel").Range("A1:AA" & letzte).Clear

    ' Kopiert die Überschrift
    Worksheets("Quelle").Range("A3:E3").Copy
    Worksheets("Ziel").Activate
    Range("A3").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
    Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    Worksheets("Ziel").Range("A4").Activate
   
 Sheets(Blatt1).Activate
 Range("A4").Select
 iAnz = 0
 I = 0

 Do Until I = ActiveSheet.UsedRange.Rows.Count
  If ActiveCell.Value = "1" Then
     Selection.EntireRow.Copy
     Sheets(Blatt2).Activate
     ActiveSheet.Paste
     ActiveCell.Offset(1, 0).Select
     Sheets(Blatt1).Select
     ActiveCell.Offset(1, 0).Select
     iAnz = iAnz + 1
     Else
     ActiveCell.Offset(1, 0).Select
   End If
   I = I + 1
 Loop

  MsgBox "Es wurden " & iAnz & " Sätze übertragen"
 
 Application.CutCopyMode = False
 Application.ScreenUpdating = True

End Sub