Hallo, in folgendem Makro suche ich alle Zugänge (Quelldatei, Spalte AC) und Abgänge Quelldatei, Spalte AQ). Die dazugehörigen Namen werden dann von Spalte A1 aus der Quelldatei in die Zieldatei übertragen. Dabei listet es die Zugänge von Zeile 16 noch oben und die Abgänge von Zeile 17 nach unten auf. In folgendem Makro funktioniert das für das Jahr 2000. Ist es möglich, eine Schleife so zu setzten, damit es automatisch mit dem Jahr 2001 weitermacht und die Daten dann in der Zieldatei eine Spalte weiter (22) kopiert? Das würde bis zum Jahr 2021 so weitergehen. Für Eure Hilfe wäre ich Euch sehr dankbar!!! Gruß David

Option Explicit

Sub Grafik()

    Dim Ziel As Worksheet, Quelle As Worksheet, Home As Worksheet

    Dim Objekt_Finden As Object
    Dim sArr() As String, sBer() As String
    Dim Spalte_ErsteAdresse As String, Spalte_Suchen As String
    Dim i As Integer, n As Integer, Ausgabe_Zeile As Long

' <<< Spalten in Quelldatei, die in Zieldatei übernommen werden >>>
    Const csSpalten = "A1"
 
' <<< Quelldatei öffnen >>>
    Workbooks.xxxxx, Password:=xxxxxx

' <<< Quell- und Zielblatt setzen >>>
    Set Quelle = Worksheets("Datenerfassung")
    Set Ziel = ThisWorkbook.Worksheets("Grafik")
    Set Home = ThisWorkbook.Worksheets("Startseite")
    sArr = Split(csErsetz, ",")
    sBer = Split(csSpalten, ",")
    
' <<< Datum in Jahr umwandlen >>>
    Quelle.Range("AQ:AQ, AC:AC").NumberFormat = "YYYY"
         
    Spalte_Suchen = 2000
    If Spalte_Suchen = "" Then Exit Sub
 
' <<< Erste Ausgabezeile in der Zieldatei >>>
    Ausgabe_Zeile = 17
 
' <<< Erstes Feld mit dem Suchbegriff suchen >>>
        Set Objekt_Finden = Quelle.Range("AC:AC").Find _
            (Spalte_Suchen, LookIn:=xlValues, LookAt:=xlWhole)

        If Not Objekt_Finden Is Nothing Then
            Spalte_ErsteAdresse = Objekt_Finden.Address
                Do
        Ausgabe_Zeile = Ausgabe_Zeile - 1
            For n = 0 To UBound(sBer)
                Ziel.Cells(Ausgabe_Zeile, n + 21).Value _
                = Quelle.Range(Replace(sBer(n), "1", Objekt_Finden.Row)).Value
            Next n
                    
' <<< Schleife für nächsten Suchbegriff >>>
        Set Objekt_Finden = Quelle.Range("AC:AC").FindNext(Objekt_Finden)
     Loop While Not Objekt_Finden Is Nothing And Objekt_Finden.Address <> Spalte_ErsteAdresse
  End If
' <<< Zeilen im Quellblatt löschen >>>
    Dim lz As Integer, t As Integer
      
    lz = Quelle.Cells(Rows.Count, "E").End(xlUp).Rows.Row
 
  ' <<< Erste Ausgabezeile in der Zieldatei >>>
    Ausgabe_Zeile = 16
 
' <<< Erstes Feld mit dem Suchbegriff suchen >>>
        Set Objekt_Finden = Quelle.Range("AQ:AQ").Find _
            (Spalte_Suchen, LookIn:=xlValues, LookAt:=xlWhole)

        If Not Objekt_Finden Is Nothing Then
            Spalte_ErsteAdresse = Objekt_Finden.Address
                Do
        Ausgabe_Zeile = Ausgabe_Zeile + 1
            For n = 0 To UBound(sBer)
                Ziel.Cells(Ausgabe_Zeile, n + 21).Value _
                = Quelle.Range(Replace(sBer(n), "1", Objekt_Finden.Row)).Value
            Next n
        
' <<< Schleife für nächsten Suchbegriff >>>
        Set Objekt_Finden = Quelle.Range("AQ:AQ").FindNext(Objekt_Finden)
     Loop While Not Objekt_Finden Is Nothing And Objekt_Finden.Address <> Spalte_ErsteAdresse
  End If
                          
' <<< Quelldatei schließen und zurück zur Zieldatei >>>
        Workbooks("Stammdaten.xlsm").Close SaveChanges:=False
        Ziel.Range("A1").Activate
                
End Sub