Dateien/Zeilen auslesen

Bild

Betrifft: Dateien/Zeilen auslesen
von: Schokohexe
Geschrieben am: 30.05.2015 18:42:48

Hallo
Bin in Sachen VBA Anfänger und benötige Hilfe in der Umstellung eines VBA-Codes.
Ich habe eine Datei geerbt, die Zeilen von Checklisten (excel-dateien)ausliest und in eine Liste zusammenfasst.
Bisher hat dies auch wunderbar funktioniert, jedoch mit der Umstellung auf Excel 2007 geht das Makro nicht mehr (application.filesearch). Habe zwar einiges über die Thematik gefunden, jedoch habe ich es nicht zum Laufen gebracht.
Vielleicht könnt Ihr mir helfen.
Danke und Gruß Leon
VBA-Code:

Sub auslesen()
Dim wbMappe As Excel.Workbook
Dim strMappe As String
Dim strPfad As String
Dim loDateien As Long
Dim loZeile As Long
Dim boTabelle As Boolean
Dim inTabellen As Integer
    loZeile = 6
    strPfad = Ordner_Auswahl
With Application.FileSearch
         .NewSearch
         .LookIn = strPfad
         .SearchSubFolders = False
         .Filename = "*.*"
         If .Execute() > 0 Then
         For loDateien = 1 To .FoundFiles.Count
        strMappe = Mid(.FoundFiles(loDateien), Len(strPfad) + 2)
        Set wbMappe = GetObject(strPfad & "\" & strMappe)
          With wbMappe
         For inTabellen = 1 To .Worksheets.Count
         If .Worksheets(inTabellen).Name = "Summery" Then
    boTabelle = True
    Exit For
End If
Next inTabellen
If boTabelle = True Then
ThisWorkbook.Worksheets("Checklisten").Cells(loZeile, 1) = strMappe
.Worksheets(inTabellen).Range("B5:LA5").Copy
ThisWorkbook.Worksheets("Checklisten").Cells(loZeile, 2).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
boTabelle = False
End If
.Close
End With
loZeile = loZeile + 1
Next loDateien
End If
End With
End Sub
Function Ordner_Auswahl()
Const WINDOW_HANDLE = 0
Const FOLDERS_ONLY As Long = 1
Const DEFPATH As Variant = ""       ' z.B. Vorgabepfad "D:\" angeben
Dim Wscript As Application
Dim objShell As Object
Dim objFolder As Object
Dim objFolderItem As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "Wählen Sie einen Ordner aus: ", _
FOLDERS_ONLY, DEFPATH)
'Set objFolder = objShell.BrowseForFolder(0&, "Ordner wählen oder anlegen...", FOLDERS_ONLY, _
DEFPATH)
If objFolder Is Nothing Then Exit Function
Set objFolderItem = objFolder.Self
Ordner_Auswahl = objFolderItem.Path
End Function

Bild

Betrifft: AW: Dateien/Zeilen auslesen
von: fcs
Geschrieben am: 31.05.2015 11:09:12
Hallo Leon.
nachfolgend dein Makro entsprechend angepasst.
Den Suchstring für die Dir-Funktion muss du ggf. noch etwas anpassen.
Bei der Function Ordner_Auswahl kannst du mit deiner Variante weiter arbeiten oder meine nehmen, die eine VBA-interne Methode für den Auswahldialog verwendet.
Gruß
Franz

Sub auslesen()
    Dim wbMappe As Excel.Workbook
    Dim wksZiel As Excel.Worksheet
    Dim strMappe As String
    Dim strPfad As String
    Dim loZeile As Long, StatusCalc As Long
    Dim inTabellen As Integer
    
    loZeile = 6
    strPfad = Ordner_Auswahl()
    If strPfad = "" Then Exit Sub
    
    strMappe = Dir(strPfad & "\*.xlsx", vbNormal)
    If strMappe = "" Then Exit Sub
    
    Set wksZiel = ThisWorkbook.Worksheets("Checklisten")
    
    'Makrobremsen lösen
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        StatusCalc = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    Do Until strMappe = ""
        Set wbMappe = GetObject(strPfad & "\" & strMappe)
        With wbMappe
            For inTabellen = 1 To .Worksheets.Count
                If .Worksheets(inTabellen).Name = "Summery" Then
                    wksZiel.Cells(loZeile, 1) = strMappe
                    .Worksheets(inTabellen).Range("B5:LA5").Copy
                    wksZiel.Cells(loZeile, 2).PasteSpecial Paste:=xlValues
                    Application.CutCopyMode = False
                    loZeile = loZeile + 1
                    Exit For
                End If
            Next inTabellen
            .Close savechanges:=False
        End With
        strMappe = Dir
    Loop
    
    'Makrobremsen zurücksetzen
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .Calculation = StatusCalc
    End With
End Sub
Function Ordner_Auswahl(Optional ByVal strInitialFolder As String, _
        Optional ByVal strTitle As String = "Bitte Ordner auswählen") As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
       .Title = strTitle
       If strInitialFolder <> "" Then .InitialFileName = strInitialFolder
       If .Show = -1 Then
            Ordner_Auswahl = .SelectedItems(1)
       End If
    End With
End Function


Bild

Betrifft: AW: Dateien/Zeilen auslesen
von: Leon
Geschrieben am: 31.05.2015 20:16:10
Hallo Franz
Velen Dank funktioniert sehr gut. Dies hilft mir sehr
Gruß
Leon

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Dateien/Zeilen auslesen"