Pfadangabe über Auswahlfenster
24.07.2007 08:41:03
Jens
ich habe des öfteren das Problem mehrere Exceldateien zu einer Datei zusammenfassen zu müssen. Dazu habe ich schon nachfolgendes Skript gefunden, dass auch funktioniert. Meine Frage wäre, ob es möglich ist die Pfadangabe zu dem Ordner über ein Auswahlfenster (Explorerfenster) laufen zu lassen so dass man nicht jedes Mal im Skript den Pfad ändern muss?
Option Explicit
Sub CopySheetFromFile()
Dim objNew As Workbook, ObjWb As Workbook
Dim objFS As FileSearch
Dim strPath As String
Dim intIndex As Integer
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
strPath = "C:\...\Daten" 'Pfad zu den Dateien - Anpassen!
Set objNew = Workbooks.Add(xlWBATWorksheet)
Set objFS = Application.FileSearch
With objFS
.NewSearch
.LookIn = strPath
.FileType = msoFileTypeExcelWorkbooks
.SearchSubFolders = False
If .Execute > 0 Then
For intIndex = 1 To .FoundFiles.Count
Set ObjWb = Workbooks.Open(.FoundFiles(intIndex))
ObjWb.Sheets(1).Copy after:=objNew.Sheets(objNew.Sheets.Count)
ObjWb.Close False
Set ObjWb = Nothing
Next
End If
End With
objNew.Sheets(1).Delete
ErrExit:
Set objNew = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
End Sub