AW: Alles in eine Datei kopieren
07.11.2004 22:23:36
Rolf
Hallo Georg,
schau mal, ob das dein Problem löst
FG
Rolf
Option Explicit
Dim WS As Worksheet
'Startprozedur
Sub start_copy_pgm()
Const VerzDefault As Variant = "C:\arbeitsdateien"
Dim verz As String
Set WS = ActiveWorkbook.ActiveSheet
verz = Ordner_def(VerzDefault)
ChDir verz
Application.ScreenUpdating = False
ShowFileList (verz)
End Sub
'Excel-Dateien öffnen
Sub ShowFileList(folderspec)
Dim exapp As Object
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
Set exapp = GetObject(folderspec & "\" & fl.Name)
Set quellbereich = exapp.Sheets(1).[a1].CurrentRegion
Call kopieren(quellbereich)
Call schliessen(fl.Name)
End If
Next
End Sub
'Kopierprozedur
Sub kopieren(quelle)
Dim zielbereich As Range
Dim r As Integer
r = WS.UsedRange.Rows.Count + 1
Set zielbereich = WS.Range("A" & r)
quelle.Copy zielbereich
End Sub
'Schließprozedur
Sub schliessen(wind)
Windows(wind).Visible = True
Application.DisplayAlerts = False
Workbooks(wind).Close
End Sub
'Ordnerdefinition
'aus Herber-Forum von K.Rola am 11.10.04
Function Ordner_def(defaultwert As Variant) As String
Dim objFolderItem As Object, strPath As String, objShell As Object
Dim objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultwert)
If objFolder Is Nothing Then End
Set objFolderItem = objFolder.Self
strPath = objFolderItem.Path
Ordner_def = strPath
End Function