AW: Excel Dateien per Makro aus Ordner zusammenfügen
29.11.2009 19:04:54
Josef
Hallo Vera,
probier mal.
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub mergeFiles()
Dim strFile As String, strPath As String
Dim objWB As Workbook, objNewWb As Workbook
On Error GoTo ErrExit
GMS
strPath = fncBrowseForFolder
If strPath <> "" Then
strFile = Dir(strPath & "\*.xls*", vbNormal)
Do While strFile <> ""
If objNewWb Is Nothing Then
Set objNewWb = Workbooks.Add(xlWBATWorksheet)
End If
Set objWB = Workbooks.Open(strPath & "\" & strFile)
objWB.Sheets(1).Copy after:=objNewWb.Sheets(objNewWb.Sheets.Count)
objWB.Close False
objNewWb.Sheets(objNewWb.Sheets.Count).Name = Left(strFile, InStrRev(strFile, ".") - 1)
strFile = Dir
Loop
If Not objNewWb Is Nothing Then objNewWb.Sheets(1).Delete
End If
ErrExit:
With Err
If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
.Description & vbLf & vbLf & "In Prozedur (mergeFiles) in Modul Modul3", _
vbExclamation, "Fehler in Modul3 / mergeFiles"
End With
GMS True
Set objWB = Nothing
Set objNewWb = Nothing
End Sub
Public Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function
Gruß Sepp