Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Excel Dateien per Makro aus Ordner zusammenfügen | Herbers Excel-Forum


Betrifft: Excel Dateien per Makro aus Ordner zusammenfügen von: Vera Singer
Geschrieben am: 29.11.2009 17:35:12

Hallo allerseits,

ich suche ein Makro, welches alle xls-Dateien (jede Datei enthält nur ein Arbeitsblatt) zu einer Arbeitsmappe zusammen führt.

Beispiel: Order c:\test enthält 5 xls.-Dateien, diese sollen zu einer Master.xls mit 5 "Reitern" zusammengeführt werden. Cpoy & paste würde zu lange dauern, da ich dies für viel einzelne
Ordener machen muß, daher mein Lösungswunsch nach Automatisierung per VBA.

Kann mir hier jemand helfen ?

Dabke und Gruß

verasi

  

Betrifft: AW: Excel Dateien per Makro aus Ordner zusammenfügen von: Josef Ehrensberger
Geschrieben am: 29.11.2009 19:04:54

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



Beiträge aus den Excel-Beispielen zum Thema "Excel Dateien per Makro aus Ordner zusammenfügen"