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
Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden
Suche nach den besten AntwortenEntdecke unsere meistgeklickten Beiträge in der Google Suche
Top 100 Threads jetzt ansehen