HERBERS Excel-Forum - das Archiv
Bewerten Sie hier bitte das Excel-Portal
Verzeichnis und Unterverzeichnis dateien öffnen
alex

Hallo liebe Mitstreiter,
gibt es eine Möglichkeit folgenden code so umzuschreiben das im Verzeichnis , auch die Dateien im Unterverzeichnissen geöffnet werden?
Sub clean_Jahreswartung()
Dim strDatei As String, dat As Workbook
Dim name As String
Dim fullname As String
pfad = ThisWorkbook.Path & "\" & "BMA"
strDatei = Dir(pfad & "\" & "*.xls")
Do Until strDatei = ""
strDatei = pfad & "\" & strDatei
Set dat = Workbooks.Open(strDatei)
With dat.Sheets("KT")
.Range("E18:G1900").ClearContents
.Range("I18:K1900").ClearContents
.Range("M18:O1900").ClearContents
.Range("Q18:S1900").ClearContents
End With
dat.Save
dat.Close True
strDatei = Dir()
Loop
End Sub
Im Verzeichnis BMA befinden sich 8 weitere Verzeichnisse. Die alle Dateien enthalten, die jeweils geöffnet, die Bereiche gelöscht und danach gespeicht und geschlossen werden sollen.
Gruß und Dank im Vorraus
alex

AW: Verzeichnis und Unterverzeichnis dateien öffnen
Josef

Hallo Alex,
ungetestet!
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub clean_Jahreswartung()
  Dim objFiles() As Object, objWb As Workbook
  Dim lngResult As Long, lngIndex As Long
  Dim strPath As String
  
  On Error GoTo ErrExit
  GMS
  
  strPath = ThisWorkbook.Path & "\" & "BMA"
  
  lngResult = FileSearchINFO(objFiles, strPath, "*.xls*", True)
  
  If lngResult > 0 Then
    For lngIndex = 0 To lngResult - 1
      Set objWb = Workbooks.Open(objFiles(lngIndex))
      With objWb
        If SheetExist("KT", objWb) Then
          With .Sheets("KT")
            .Range("E18:G1900").ClearContents
            .Range("I18:K1900").ClearContents
            .Range("M18:O1900").ClearContents
            .Range("Q18:S1900").ClearContents
          End With
        End If
        .Close True
      End With
    Next
  End If
  
  ErrExit:
  With Err
    If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
      .Description & vbLf & vbLf & "In Prozedur (clean_Jahreswartung) in Modul Modul1", _
      vbExclamation, "Fehler in Modul1 / clean_Jahreswartung"
  End With
  
  GMS True
  Set objWb = 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



'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


Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If wks.name = sheetName Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function

Gruß Sepp

AW: Verzeichnis und Unterverzeichnis dateien öffnen
alex

Hallo und vielen dank für eure mühen.
der code von nepumuk funktioniert einwandfrei.
den anderen habe ich noch nicht versucht.
allerdings werde ich wohl bei nepumuks code bleiben da er um einiges kürzer ist und für mich völlig ausreichend ist
Dank und Gruß
alex
AW: Verzeichnis und Unterverzeichnis dateien öffnen
Nepumuk

Hallo,
versuch es mal so:
Option Explicit

Sub clean_Jahreswartung()
    Dim strPfad As String
    Dim lngIndex As Long
    Dim objWorkbook As Workbook
    
    strPfad = ThisWorkbook.Path & "\" & "BMA"
    
    With Application.FileSearch
        
        .NewSearch
        .SearchSubFolders = True
        .LookIn = strPfad
        .FileType = msoFileTypeExcelWorkbooks
        .Execute
        
        For lngIndex = 1 To .FoundFiles.Count
            
            Set objWorkbook = Workbooks.Open(.FoundFiles.Item(lngIndex))
            
            With objWorkbook.Sheets("KT")
                .Range("E18:G1900").Value2 = Empty
                .Range("I18:K1900").Value2 = Empty
                .Range("M18:O1900").Value2 = Empty
                .Range("Q18:S1900").Value2 = Empty
            End With
            
            objWorkbook.Close SaveChanges:=True
            
        Next
    End With
End Sub

Gruß
Nepumuk