Sub Datenuebernahme()
On Error Resume Next
Dim Pfad As String
Dim Name As String
Dim Name2 As String
Dim Datei As String
Dim i As Integer
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Pfad = ThisWorkbook.Path
Name = ThisWorkbook.Name
With Application.FileSearch
.NewSearch
.LookIn = Pfad
'.SearchSubFolders = True
.Filename = "*.xls"
' Sucht nach den Files
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
' Aktionen ausführen - 1.Tabellenblatt löschen und das andere komplett hierhin einfügen
Datei = Pfad & "\" & Dir(.FoundFiles(i))
If Datei = Pfad & "\" & ThisWorkbook.Name Then GoTo weiter
Workbooks.Open Filename:=Datei
Name2 = ActiveWorkbook.Name
Sheets(1).Delete
Workbooks(Name).Sheets(1).Select
Workbooks(Name).Sheets(1).Copy Before:=Workbooks(Name2).Sheets(1)
ActiveWorkbook.Close Savechanges:=True
weiter:
Next i
End If
MsgBox "Ich habe nun " & .FoundFiles.Count - 1 & " Dateien angepasst.", , "Fertig"
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub