Hallo

Ich möchte gern ein Skript schrieben, dass ein Excel File z.B \blabla\bla1_Datum nimmt und dann in einem anderen Ordner alle Excel Files die dort drin sind überprüft, ob der Wert in den jeweiligen Spalten B2 (ein Datum) der Files mit dem Datum im Filenamen, in diesem Fall \blabla\bla1_Datum übernimmt. Wenn Ja werden bestimmte Spalten A2, B2, usw. bis J2 in das File \blabla\bla1_Datum übertragen. Und das macht es mit jedem File im diesem Ordner. Am Schluss speichert es alles und nimmt dann das nächste File \blabla\bla2_Datum und geht wieder in diesem Ordner Files durch und macht nochmal das gleiche und wird dann automatisch gespeichert. Und das Skript soll das solange mach bis es kein File mehr findet der \blabla\bla(hier kommt dann eine Nummer) _Datum heisst. Das heisst bei jedem Durchlauf soll das Datum und die Nummer im Filename um eins erhört werden bis kein File mehr findet das so heisst.

Das ist was ich bis jetzt habe und habe mir gedacht das Ganze in eine Schleife zupacken und die Variable num und das Datum bei jedem durchlauf um eins zu erhöhen.Option Explicit

Option Compare Text
  
Const Folder = "D:\Test_Umgebung\Orders_xlsx"
  
Public Sub test2()
      
Dim Datei As String
Dim Verzeichnis As String
Dim SaveDummy As Variant
Dim Datum As Date
Dim num As String
Dim Filename As String
Dim aktDate As Date
Dim Wkb As Workbook, Fso As Object, file As Object, Zeile As Long
Dim Wkb2 As Workbook

      
aktDate = "17.10.2017"
num = "1"

      
With Application
    .ScreenUpdating = False     'Bildschirmaktualisierung aus
    .AskToUpdateLinks = False   'Verknüpfung (Name aus Übersicht) ohne Abfrage aktualisieren
    .DisplayAlerts = False      'Fehlermeldung "Verknüpfung kann nicht..." unterdrücken
End With
        
Set Fso = CreateObject("Scripting.FileSystemObject")    'Dateisystem-Operationen
      
Workbooks.Open "D:\Test_Umgebung\xls_File_pro_Migrationstag\UC50_SAFE_LAURA_" & aktDate & "--" & num & ".xlsx"
Set Wkb2 = Workbooks.Open("D:\Test_Umgebung\xls_File_pro_Migrationstag\UC50_SAFE_LAURA_" & aktDate & "--" & num & ".xlsx")
For Each file In Fso.GetFolder(Folder).Files  'Alle _orders.xlsx-Dateien einlesen und eintragen
    If Fso.GetExtensionName(file.Name) Like "xlsx" And Fso.GetBaseName(file.Name) Like "*orders*" Then
        Set Wkb = GetObject(file.Path)
            With Wkb.Sheets(1) 'Werte mit Zahlenformat werden erst geptrüft
                    'Wenn Feld B2 aus dem File orders.xls =
                    'das Datum das beim neuen File eingeben wurde dann coppy Restliche Felder
                    If Wkb.Sheets(1).Range("B2").Value = aktDate Then
                         
                        '### Ermitteln der ersten freien Zelle in Spalte A ###
                        Zeile = Cells(Rows.Count, 1).End(xlUp).Row + 1
                        '### Wenn erste freie Zeile kleiner 3 dann in 3 beginnen ###
                        If Zeile < 3 Then Zeile = 3
                        .Range("A2").Copy:  Cells(Zeile, "A").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        .Range("B2").Copy:  Cells(Zeile, "B").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        .Range("C2").Copy:  Cells(Zeile, "C").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        .Range("D2").Copy:  Cells(Zeile, "D").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        .Range("E2").Copy:  Cells(Zeile, "E").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        .Range("F2").Copy:  Cells(Zeile, "F").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        .Range("G2").Copy:  Cells(Zeile, "G").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        .Range("H2").Copy:  Cells(Zeile, "H").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        .Range("I2").Copy:  Cells(Zeile, "I").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        .Range("J2").Copy:  Cells(Zeile, "J").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                    End If
            End With
        Wkb.Close False
    End If
Next
 
With Application
    .ScreenUpdating = True
    .AskToUpdateLinks = True
    .DisplayAlerts = True
End With
Wkb2.Save
Workbooks.Close
End Sub