AW: Eine Datei aus mehreren zusammenbauen
03.11.2005 10:36:04
Rolf
Hallo Kristian,
versuch's mal hiermit
fG
Rolf
Option Explicit
Public WS As Worksheet
Public action$
'Startprozedur
Sub start_filehandle()
'(C) Rolf Beißner 10.2004
Dim verz$
verz = FolderGet("G:\") 'Defaultwert für das Verzeichnis, das AUSSCHLIESSLICH
'die abzuarbeitenden Dateien enthält
ChDir verz
action = "CopyArea"
Application.ScreenUpdating = False
Set WS = Sheets.Add
Call WorkFileList(verz)
End Sub
'Excel-Dateien öffnen
Sub WorkFileList(folderspec As String)
Dim exapp As Object, fs As Object, f As Object, fc As Object, fl As Object
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
'Set exapp = Workbooks.Open(folderspec & "\" & fl.Name)'Alternative zu Getobject
Set exapp = GetObject(folderspec & "\" & fl.Name)
Application.Run action, exapp 'ausgewählte Aktion starten
Call WinClose(fl.Name)
End If
Next
End Sub
'Schließprozedur
Sub WinClose(wind As String)
Windows(wind).Visible = True
Application.DisplayAlerts = False
Workbooks(wind).Close
End Sub
'Ordnerauswahl
Function FolderGet(Optional ByVal def = "")
Dim objShell As Object, objfolder As Object
Set objShell = CreateObject("Shell.Application")
Set objfolder = objShell.BrowseForFolder(0, "Bitte einen Ordner wählen", 0, def)
If objfolder Is Nothing Then End
FolderGet = objfolder.Self.Path
End Function
'Area kopieren
Sub CopyArea(qfile As Workbook)
Dim rz%, rq%
Dim zielbereich As Range, quellbereich As Range
rz = WS.Cells(65536, 1).End(xlUp).Row + 1
rq = qfile.Sheets(1).Cells(65536, 1).End(xlUp).Row
Set zielbereich = WS.Range("A" & rz)
Set quellbereich = qfile.Sheets(1).Range("A5:IV" & rq)
quellbereich.Copy zielbereich
End Sub