Thema Datum  Von Nutzer Rating
Antwort
02.06.2020 08:28:01 Hämmer
NotSolved
02.06.2020 08:44:00 Mase
NotSolved
02.06.2020 09:25:50 Gast66051
NotSolved
02.06.2020 09:27:28 Hämmer
NotSolved
02.06.2020 10:43:45 Mase
NotSolved
02.06.2020 11:48:27 Hämmer
NotSolved
02.06.2020 12:02:12 Mase
NotSolved
02.06.2020 12:14:47 Gast66260
NotSolved
Rot Ordnerverzeichnis (inkl. Unterordner) nach Excel Dateien durchsuchen und öffnen
02.06.2020 12:42:32 Mase
Solved
02.06.2020 12:48:48 Hämmer
Solved
02.06.2020 13:48:05 Hämmer
NotSolved
02.06.2020 15:20:49 Mase
NotSolved
03.06.2020 06:00:53 Hämmer
NotSolved
03.06.2020 11:14:03 Mase
Solved
03.06.2020 12:17:44 Hämmer
Solved

Ansicht des Beitrags:
Von:
Mase
Datum:
02.06.2020 12:42:32
Views:
2194
Rating: Antwort:
 Nein
Thema:
Ordnerverzeichnis (inkl. Unterordner) nach Excel Dateien durchsuchen und öffnen

Kein Ding; jeder hat mal angefangen.

Option Explicit
Dim vRet As Variant
Dim mFso As Object
Const m_sPfad As String = "G:\DATEN\Herstellberichte\" '<----anpassen
Const m_FileExtension As String = ".XLSM" '<---- Dateityp anpassen und in Großbuchstaben angeben
 
Dim lCalc As Long
Dim lEvent As Long
Dim lStatusbar As Long
Dim lScreen As Long
 
Sub main()
 
    On Error GoTo FinishErr
    '*** Inputbox den gesuchten Dateinamen zu erhalten
    vRet = InputBox("Nach welchem File soll gesucht werden?", "Dateinamenabfrage")
    '*** *** Wenn leer dann Sub wortlos verlassen
    If vRet = "" Then Exit Sub
    
    '*** speed up
    Call TurnOffFunctionality
    '*** Ordner durchsuchen
    Set mFso = CreateObject("Scripting.FileSystemObject")
    Call OrdnerDurchsuchen(mFso.GetFolder(m_sPfad))
         
FinishErr:
If err.Number <> 0 Then
    MsgBox err.Number & vbCrLf & err.Description
 End If
  
    '*** Standard speed
    Call TurnOnFunctionality
 
Set mFso = Nothing
End Sub
 
Sub OrdnerDurchsuchen(ByRef oFolder As Object)
    Dim oSubFldr As Object
    Dim oFile As Object
    '*** Unterordner durchsuchen
    For Each oSubFldr In oFolder.SubFolders
        Call OrdnerDurchsuchen(oSubFldr)
    Next
    '*** Dateien in den Unterordner
    For Each oFile In oFolder.Files
        '*** Wenn Dateintyp stimmt
        If UCase(Right(oFile.Name, 5)) = m_FileExtension Then
            '*** Wenn Inhalt der Inputbox mit Datei übereinstimmt
            If UCase(oFile.Name) = UCase(vRet & m_FileExtension) Then
                '*** dann öffne das File
                Dim wkb As Excel.Workbook
                Set wkb = Application.Workbooks.Add(oFile.Path)
            End If
        End If
    Next
    '*** Objektreferenzen entlassen
    Set oSubFldr = Nothing
    Set oFile = Nothing
    Set wkb = Nothing
End Sub
 
Public Sub TurnOffFunctionality()
    With Application
        lCalc = .Calculation: .Calculation = xlCalculationManual
        lStatusbar = .DisplayStatusBar: .DisplayStatusBar = False
        lEvent = .EnableEvents: .EnableEvents = False
        lScreen = .ScreenUpdating: .ScreenUpdating = False
    End With
End Sub
Public Sub TurnOnFunctionality()
    With Application
        .Calculation = lCalc
        .DisplayStatusBar = lStatusbar
        .EnableEvents = lEvent
        .ScreenUpdating = lScreen
    End With
End Sub

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
02.06.2020 08:28:01 Hämmer
NotSolved
02.06.2020 08:44:00 Mase
NotSolved
02.06.2020 09:25:50 Gast66051
NotSolved
02.06.2020 09:27:28 Hämmer
NotSolved
02.06.2020 10:43:45 Mase
NotSolved
02.06.2020 11:48:27 Hämmer
NotSolved
02.06.2020 12:02:12 Mase
NotSolved
02.06.2020 12:14:47 Gast66260
NotSolved
Rot Ordnerverzeichnis (inkl. Unterordner) nach Excel Dateien durchsuchen und öffnen
02.06.2020 12:42:32 Mase
Solved
02.06.2020 12:48:48 Hämmer
Solved
02.06.2020 13:48:05 Hämmer
NotSolved
02.06.2020 15:20:49 Mase
NotSolved
03.06.2020 06:00:53 Hämmer
NotSolved
03.06.2020 11:14:03 Mase
Solved
03.06.2020 12:17:44 Hämmer
Solved