Alle Excel-Dateien in einem Verzeichnis öffnen

Niclas · 2017-08-26T17:26:48+00:00

Hallo zusammen, folgende Problemstellung: Ich will mittels der INDIREKT-Funktion Daten aus anderen Excel-Dateien zusammentragen. Dies funktioniert ja bekanntermaßen nur, wenn diese Dateien auch geöffnet sind. Daher versuche ich momentan ein Makro zu bauen, das alle Excel-Dateien in einem bestimmten Verzeichnis (sowie auch die Dateien in allen Unterordnern!) öffnet. Die Dateien im Zielpfad zu öffnen funktioniert auch bereits, nur weiß ich leider nicht, wie ich die Unterordner mit einbeziehen kann. Der Code sieht momentan so aus: Sub GetData() Dim pfad As String, Dateiname As String, iRow As Long Application.ScreenUpdating = False pfad = "C:\Users\xxx\Desktop\01_07\" Dateiname = Dir(pfad & "*.xlsx") Do While Dateiname "" Workbooks.Open Filename:=pfad & Dateiname Dateiname = Dir() Loop End Sub Über einen Tipp wäre ich sehr dankbar! MfG

Hallo Niclas,
eine Möglichkeit.

' **********************************************************************
' Modul: Modul2  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub getData()
Dim strPath As String, strFile As String, strTab As String, strFormula As String
Dim varRanges As Variant
Dim lngDate As Long, lngEnd As Long, lngI As Long, lngR As Long

On Error GoTo ErrorHandler

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .AskToUpdateLinks = False
  .DisplayAlerts = False
  .Calculation = xlCalculationManual
End With

varRanges = Array("A15", "D16", "D17", "D18")

lngEnd = IIf(Month(DateSerial(Year(Date), 2, 29)) = 3, 365, 366)

strPath = "E:\Forum\" 'Stammverzeichnis

strTab = "Tabelle1" 'Tabellenname

With ThisWorkbook.Sheets("Tabelle2")  'Name der Ausgabetabelle
  For lngDate = 1 To lngEnd
    strFile = Dir(strPath & Format(DateSerial(Year(Date), 1, lngDate), "DD_MM") & "\*.xlsx", vbNormal)
    If strFile <> "" Then
      lngR = lngR + 1
      strFormula = "='" & strPath & "[" & strFile & "]" & strTab & "'!"
      For lngI = 0 To UBound(varRanges)
        .Cells(lngR, 5 + lngI).Formula = strFormula & varRanges(lngI)
      Next
    End If
  Next
  .Range("E1").Resize(lngR, 4) = .Range("E1").Resize(lngR, 4).Value
End With




ErrorHandler:

If Err.Number <> 0 Then
  MsgBox "Fehler in Modul2" & vbLf & vbLf & "Prozedur:" & vbTab & "getData" & vbLf & _
    "Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _
    IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!"
  Err.Clear
End If

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .AskToUpdateLinks = True
  .DisplayAlerts = True
  .Calculation = xlCalculationAutomatic
End With

End Sub

Wahrscheinlich sollt der Dateiname oder Pfad auch noch irgendwo hin, aber du kannst dich ja nochmals melden.

Gruß Sepp

Hallo Niclas,
da hatte sich ein fehler eingeschlichen.

' **********************************************************************
' Modul: Modul2  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub getData()
Dim strPath As String, strFile As String, strTab As String, strFormula As String
Dim varRanges As Variant
Dim lngDate As Long, lngEnd As Long, lngI As Long, lngR As Long

On Error GoTo ErrorHandler

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .AskToUpdateLinks = False
  .DisplayAlerts = False
  .Calculation = xlCalculationManual
End With

varRanges = Array("A15", "D16", "D17", "D18")

lngEnd = IIf(Month(DateSerial(Year(Date), 2, 29)) = 3, 365, 366)

strPath = "E:\Forum\" 'Stammverzeichnis

strTab = "Tabelle1" 'Tabellenname

With ThisWorkbook.Sheets("Tabelle2")  'Name der Ausgabetabelle
  For lngDate = 1 To lngEnd
    strFile = Dir(strPath & Format(DateSerial(Year(Date), 1, lngDate), "DD_MM") & "\*.xlsx", vbNormal)
    If strFile <> "" Then
      lngR = lngR + 1
      strFormula = "='" & strPath & Format(DateSerial(Year(Date), 1, lngDate), "DD_MM") & "\[" & strFile & "]" & strTab & "'!"
      For lngI = 0 To UBound(varRanges)
        .Cells(lngR, 5 + lngI).Formula = strFormula & varRanges(lngI)
      Next
    End If
  Next
  .Range("E1").Resize(lngR, 4) = .Range("E1").Resize(lngR, 4).Value
End With

ErrorHandler:

If Err.Number <> 0 Then
  MsgBox "Fehler in Modul2" & vbLf & vbLf & "Prozedur:" & vbTab & "getData" & vbLf & _
    "Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _
    IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!"
  Err.Clear
End If

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .AskToUpdateLinks = True
  .DisplayAlerts = True
  .Calculation = xlCalculationAutomatic
End With

End Sub

Gruß Sepp

Alle Excel-Dateien in einem Verzeichnis öffnen

Forumthread: Alle Excel-Dateien in einem Verzeichnis öffnen

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial