Hallo Community
Anrede und Gruß wäre auch nicht schlecht!
Gruß Nighty
Quelle
Alle Dateien eines ausgewählten Ordners
Worksheeets(1)
Genutzter Bereich
Ziel
ThisWorkbook
Erstellung von einem Worksheets,mit dem Namen "Bus 1" mit fortlaufender Numerierung
Einfügen der zuvor kopierten Daten
und nächste Datei
Sub DateienLesen()
Call EventsOff
Dim Index As Integer
Dim Daten() As Variant
Dim DateiName As String, Dpfad As String
Dpfad = OrdnerAuswahl
DateiName = Dir(Dpfad & "*.xls")
Do While DateiName <> ""
If ThisWorkbook.Name <> DateiName Then
Index = Index + 1
ThisWorkbook.Worksheets.Add after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = "Bus " & Index
Workbooks.Open Filename:=Dpfad & DateiName
Workbooks(DateiName).Worksheets(1).UsedRange.Copy
ThisWorkbook.Worksheets("Bus " & Index).Range("A1").PasteSpecial Paste:=xlValues, Operation:=xlNone
Workbooks(DateiName).Close SaveChanges:=False
ThisWorkbook.Worksheets("Bus " & Index).Range("A1").Select
End If
DateiName = Dir
Loop
Call EventsOn
End Sub
Function OrdnerAuswahl() As String
On Error GoTo FehlerRoutine
Dim AppShell As Object
Dim BrowseDir As Variant
Set AppShell = CreateObject("Shell.Application")
Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
OrdnerAuswahl = BrowseDir.items().Item().Path & "\"
FehlerRoutine:
End Function
Public Sub EventsOff()
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
Public Sub EventsOn()
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub