Hallo,
ich bin kleiner xls VBA Anwender, der an seine Grenzen stößt:
Ich habe mehrere Workbooks (7 bis 10; Name beliebig), in denen jeweils ein Sheet ist. Diese Sheets hätte ich gerne per Makro in ein neues Workbook kopiert. Alle Datein befinden sich in einem Ordner auf dem Desktop.
Hat jemand eine schnelle Lösung ?
Hi Philipp,
ich bin kleiner xls VBA Anwender, der an seine Grenzen stößt:
sehr oft dito 
)
Ich habe mehrere Workbooks (7 bis 10; Name beliebig), in denen
jeweils ein Sheet ist. Diese Sheets hätte ich gerne per Makro
in ein neues Workbook kopiert. Alle Datein befinden sich in
einem Ordner auf dem Desktop.
Nachfragen,
sollen die Daten der Blätter untereinander im Blatt1 der neuen Mappe gelistet werden?
Wenn nicht, also jedes Blatt der ca. 8,5 Mappen *gg* soll ein neues Blatt in der neuen Mappe sein, welchen Namen soll es denn dann tragen?
Befinden sich in dem Ordner noch andere xls-Dateien die nicht eingelesen werden sollten?
Gruß
Reinhard
Gruess Dich Reinhard,
so schnell habe ich gar nicht mit einer Antwort gerechnet, aber die VBA Cracks lauern bestimmt schon auf anspruchsvolle Aufgaben. Wobei ich keinen Crack mit diesem Problem beleidigen will 
)
sollen die Daten der Blätter untereinander im Blatt1 der neuen
Mappe gelistet werden?
Ja, eine neue Mappe wäre das Beste.
Wenn nicht, also jedes Blatt der ca. 8,5 Mappen *gg* soll ein
neues Blatt in der neuen Mappe sein, welchen Namen soll es
denn dann tragen?
Ja, der Name ist ganz egal. „HansWurst“ klingt doch ganz nett
Befinden sich in dem Ordner noch andere xls-Dateien die nicht
eingelesen werden sollten?
Nein, in dem Ordner sind nur die Dateien mit den zu importierenden Sheets.
Gut, vielen Dank und viel Spass.
Ja, eine neue Mappe wäre das Beste.
Wenn nicht, also jedes Blatt der ca. 8,5 Mappen *gg* soll ein
neues Blatt in der neuen Mappe sein, welchen Namen soll es
denn dann tragen?Ja, der Name ist ganz egal. „HansWurst“ klingt doch ganz nett
Hi Philipp,
Suchverzeichnis anpassen:
Option Explicit
'
Sub Einlesen()
Dim fs As FileSearch, F As Integer, Merk1 As String, Merk2 As String
On Error GoTo Fehler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Set fs = Application.FileSearch
With fs
.LookIn = "Y:\Irgendwo"
.SearchSubFolders = False
.Filename = "\*.xls"
If .Execute() \> 0 Then
Workbooks.Add
Merk1 = ActiveWorkbook.Name
For F = 1 To .FoundFiles.Count
Workbooks.Open .FoundFiles(F), 0
Merk2 = ActiveWorkbook.Name
Sheets(1).Copy After:=Workbooks(Merk1).Sheets(Workbooks(Merk1).Sheets.Count)
ActiveSheet.Name = "Hanswurst" & Right("00" & CStr(F), 2)
Workbooks(Merk2).Close savechanges:=False
Next F
End If
End With
If F \> 0 Then
MsgBox "Es wurden " & F - 1 & " Dateien eingelesen"
Application.Dialogs(xlDialogSaveAs).Show
End If
Fehler:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Gruß
Reinhard
Klasse Reinhard,
funktioniert ausgezeichnet. besten dank.