Alle Excel-Dateien in einem Verzeichnis öffnen

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
eine Beispieldatei kann ich leider nicht liefern, da ich die Dateien momentan nicht bei mir habe.
Das System sieht so aus:
Aus der Zieldatei wird über die INDIREKT-Funktion nach Ordnern im System gesucht, einer für jeden Tag des Jahres (01_01, 01_02 usw.). Es kann sein, dass es diesen Ordner gibt, oder eben nicht. Wenn der Ordner nicht existiert und es einen Bezugsfehler gibt, ist in Excel hinterlegt, dass einfach nichts ausgegeben wird. Wenn der Bezug gefunden wird, dann liegt in diesem Ordner immer eine Exceldatei (mit nur einem Arbeitsblatt), aus der z.B. die Felder A15, D16, D17 und D18 ausgelesen und in die Zieldatei übertragen werden sollen.
In der Zieldatei habe ich die Links in die Ordnerstruktur dynamisch generiert und daraus die Funktion für die Abfrage zusammengebaut (im Zielpfad ändert sich ja jedes Mal das Datum). Über die Namensfunktion wird die (in Textform vorliegende) Funktion dann schließlich berechnet.
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

' ********************************************************************** ' 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

Beliebteste Forumthreads (12 Monate)

Alle Excel-Dateien in einem Verzeichnis öffnen

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread