Hallo Tom,
am besten ist natürlich, wie ransi schon sagt,
wenn alle Dateien im gleichen Verzeichnis sind.
Aber mit diesen Prozeduren geht's auch
in mehreren Schritten.
FG
Rolf
Option Explicit
Dim WS As Worksheet
Dim zielbereich As Range
Sub start_copy_pgm()
Dim verz As String
Set WS = ThisWorkbook.ActiveSheet
verz = Ordner_def
ChDir verz
ShowFileList (verz)
End Sub
'Excel-Dateien öffnen
Sub ShowFileList(folderspec) 'Argumentübergabe z.B "C:\excel\Arbeitsdateien"
Dim fs, f, fc, fl As Object
Dim quellbereich As Range
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
For Each fl In fc
If fl.Type = "Microsoft Excel-Arbeitsblatt" Then
Workbooks.Open (fl.Name)
Set quellbereich = Sheets(1).Range("A1:D5")
Call kopieren(quellbereich)
Application.DisplayAlerts = False
Workbooks(fl.Name).Close
End If
Next
End Sub
Sub kopieren(quelle)
Dim r As Integer
r = WS.UsedRange.Rows.Count + 1
Set zielbereich = WS.Range("A" & r)
quelle.Copy zielbereich
End Sub
'aus Herber-Forum von K.Rola am 11.10.04
Function Ordner_def()
Dim objFolderItem As Object, strPath As String, objShell As Object
Dim varDefaultPath As Variant 'wichtig muss Variant sein!
Dim objFolder As Object
varDefaultPath = "C:\"
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, varDefaultPath)
If objFolder Is Nothing Then End
Set objFolderItem = objFolder.Self
strPath = objFolderItem.Path
Ordner_def = strPath
End Function