Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1112to1116
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Dateien in Unterverzeichnissen abarbeiten

Dateien in Unterverzeichnissen abarbeiten
Werner
VBA-Level: befriedigend
Hallo Freunde,
in einem Verzeichnis namens "C:\MeinVerzeichnis" befinden sich mehrere Excel-Dateien. Diese können
dann z.B. mit folgendem Programmrahmen abgearbeitet werden.

Public Sub Rahmen()
Dim wb As Workbook
Const Verzeichnis = "C:\MeinVerzeichnis"
Dim Datei As String
ChDir Verzeichnis
Datei = Dir(Verzeichnis)
Do While Datei  ""
Set wb = Workbooks.Open(Verzeichnis & Datei)
wb.Save
wb.Close
Datei = Dir
Loop
Set wb = Nothing
End Sub
Diesen Rahmen kann man dazu verwenden, um verschiedene Bearbeitungen vorzunehmen. Die
Dateien in dem Verzeichnis werden der Reihe nach geöffnet und dann wieder geschlossen.
Was muss ich aber tun, um diesen Rahmen so anzupassen, dass auch die Dateien in allen
Unterverzeichnissen dieses Verzeichnisses mitberücksichtigt werden? Wie müsste der Rahmen
dann in Excel 2007 umgeschrieben werden?
Weiß einer von euch einen Rat? Besten Dank! Grüße Werner R.

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Dateien in Unterverzeichnissen abarbeiten
08.11.2009 10:14:34
Josef
Hallo Werner,
diese Version läuft in jeder Excelvarsion.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub test()
  Dim objFiles() As Object
  Dim result As Long, lngIndex As Long
  Dim objWb As Workbook
  
  Const cstrVerzeichnis As String = "C:\MeinVerzeichnis"
  
  On Error GoTo ErrExit
  GMS
  
  result = FileSearchINFO(objFiles, cstrVerzeichnis, "*.xls*", True)
  
  If result <> 0 Then
    For lngIndex = 0 To UBound(objFiles)
      Set objWb = Workbooks.Open(objFiles(lngIndex), UpdateLinks:=True)
      With objWb
        '....
        
        .Close True
      End With
      Set objWb = Nothing
    Next
  End If
  
  ErrExit:
  With Err
    If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
      .Description & vbLf & vbLf & "In Prozedur (test) in Modul Modul1", _
      vbExclamation, "Fehler in Modul1 / test"
  End With
  
  GMS True
  
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


'by J.Ehrensberger
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
    Optional ByVal SubFolders As Boolean = False) As Long

  
  '# PARAMETERINFO:
  '# Files: Datenfeld zur Ausgabe der Suchergebnisse
  '# InitialPath: String der das zu durchsuchende Verzeichnis angibt
  '# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
  '# Beispiele: "*.txt" - Findet alle Textdateien
  '# "*name*" - Findet alle Dateien mit "name" im Dateinamen
  '# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
  '# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)
  
  
  Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
  Dim intC As Integer, varFiles As Variant
  
  Set fobjFSO = CreateObject("Scripting.FileSystemObject")
  
  Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
  
  On Error GoTo ErrExit
  
  If InStr(1, FileName, ";") > 0 Then
    varFiles = Split(FileName, ";")
  Else
    Redim varFiles(0)
    varFiles(0) = FileName
  End If
  For Each ffsoFile In ffsoFolder.Files
    If Not ffsoFile Is Nothing Then
      For intC = 0 To UBound(varFiles)
        If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
          If IsArray(Files) Then
            Redim Preserve Files(UBound(Files) + 1)
          Else
            Redim Files(0)
          End If
          Set Files(UBound(Files)) = ffsoFile
          Exit For
        End If
      Next
    End If
  Next
  
  If SubFolders Then
    For Each ffsoSubFolder In ffsoFolder.SubFolders
      FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
    Next
  End If
  
  If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
  ErrExit:
  Set fobjFSO = Nothing
  Set ffsoFolder = Nothing
End Function

Gruß Sepp

Anzeige
Zwischenmitteilung
08.11.2009 10:43:44
Werner
Hallo Josef,
vielen herzlichen Dank für diesen ausführlichen Code!! Ich werde ihn nach und nach testen und zu
verstehen versuchen.
Die Einbeziehung der Unterverzeichnisse ist offenbar komplizierter, als es auf den ersten Blick scheint. In zwei bis drei Tagen gebe ich dir Bescheid, wie ich damit zurechtkomme.
Bis dahin mit besten Grüßen! Werner R.
Funktioniert bestens
11.11.2009 02:38:44
Werner
Hallo Josef,
nun kann ich endlich das Ergebnis deines Rahmencodes zurückmelden, den ich um eine Suchfunktion
ergänzt habe: Alle Dateien in dem angegebenen Verzeichnis werden problemlos durchsucht, auch die der Unterordner.
Dein Makrocode ist auch theoretisch sehr lehrreich: Er enthält z.B. eine Rekursion, man lernt die Ver-
wendung des Parameterzusatzes "Optional" und natürlich vor allem den Gebrauch des FileSystem-
objects.
Solche mächtigen Codes setzt man am besten bedachtsam ein, man kann dadurch Dutzende
Dateien zugleich ändern, sollte sich aber vorher überlegen, was man tut.
Noch einmal vielen herzlichen Dank für diesen sehr oft einsetzbaren Codrahmen!
Beste Grüße! Werner R.
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige