Excel Makro, VBA soll Pfad auslesen Ordner inkl. Unterordner die vorliegenden Excel Dateien öffnen und 2 bestimmt Zellen in eine neue Excel untereinander schreiben

Hallo Liebe Community,

wie bereits im Titel erwähnt soll ich in Excel ein Programm schreiben, dass das oben beschriebene tut. Also es ist so, dass es sich um einen Pfad handelt mit ca. 200 Ordnern. In jedem dieser Ordner liegt einmal die erwähnte Excel Datei und noch andere nicht relevante Sachen. Jetzt soll mein Makro den Pfad absuchen, die Excel öffnen die Zellen B20 und B21 kopieren und untereinander in die Neue Excel Datei einfügen, ohne die anderen Ergebnisse zu überschreiben. Also alles dann untereinander in die Spalte A. Ich versuche es jetzt seit vergangenem Donnerstag und komme einfach nicht weiter.

Im Voraus schon einmal Vielen Dank für die Hilfe

Gruß Timur

Please also mark the comments that contributed to the solution of the article

Content-Key: 281677

Url: https://administrator.de/contentid/281677

Printed on: April 19, 2024 at 15:04 o'clock

5 Comments

Latest comment

Moin,

da wir ungern (unbezahlt) die Arbeit von anderen Leuten machen: Was hast Du denn schon und was fehlt noch?
Klingt ganz einfach.

http://lmgtfy.com/?q=vba+verzeichnis+auslesen
http://lmgtfy.com/?q=vba+excel+datei+%C3%B6ffnen
Dazu noch 2 Schleifen und fertig

Viele Grüße

Stefan

Hallo Stefan,

ich hatte schon beide Suchen genau wie du sie mir so nett vorgeschlagen hast und habe auch schon bestimmt 8 verschieden codes in Summe ausprobiert, aber es tut sich entweder gar nichts oder es gibt mir nur Fehler Rückmeldungen und das ist auch erst mein zweites Programm, dass ich überhaupt schreiben soll, deshalb habe ich keine besonders großen Erfahrungen, was dann genau an welcher Stelle falsch ist. Ich hatte mir dass dann auch zusammen gesucht aus den Suchergebnissen, die Google ausgespuckt hat, aber es passt halt einfach nicht zusammen.

Sub FilesListen()
Application.ScreenUpdating = False
Dim Dateien As Integer
Dim DateiName As String
With Application.FileSearch
.NewSearch
.LookIn = "O:\E006\_GENERAL\MEDIA_SHARE\DOKU\LSW\elektronische Fahrzeugakte\"
.SearchSubFolders = True
.Filename = "*.xls"
If .Execute() > 0 Then
For Dateien = 1 To .FoundFiles.Count
DateiName = Dir(.FoundFiles(Dateien))
If DateiName <> ThisWorkbook.Name Then
Workbooks.Open Filename:=.FoundFiles(Dateien)
Workbooks(DateiName).Sheets("GER-MB xxx Fahrzeug Checkliste").Range("B20:B21").Copy ThisWorkbook.Sheets("Auswertung").Range("A1:A230")
Workbooks(DateiName).Close
End If
Next Dateien
End If
End With
Application.ScreenUpdating = True
End Sub

das war z.B. einer, den ich so aus den Suchergebnissen zusammen geschustert habe, für Hilfe wäre ich wirklich sehr dankbar
Gruß Timur

Hallo Timur,
auch wenn wir das hier schon diverse male gepostet haben, hier ausnahmsweise nochmal:
(In Zeile 5 den Ordner der Dateien angeben / gestartet werden muss die Methode ImportData(), im Jetzigen Zustand werden *.xlsx und *.xls verarbeitet. Sollen noch andere Extensions inkludiert werden muss das Array in Zeile 9 um diese ergänzt werden)

Für gewünschte Ergänzungen von deiner Seite bin ich offen, jedoch ist dies dann nicht mehr kostenlos. Du kannst mich in diesem Fall dann via PM kontaktieren.

Dim fso As Object
Sub ImportData()
    Dim col As New Collection, file As Variant, wb As Workbook, rngDest as Range
    'Ordner der die Dateien enthält  
    Const FOLDER = "C:\MeineDateien"  
    'Filesystemobject  
    Set fso = CreateObject("Scripting.FileSystemObject")  
    'alle Excel-Dateien rekursiv listen  
    getAllFiles fso.GetFolder(FOLDER), True, Array("xlsx", "xls"), col  
    'Screenupdates und eventuelle Dialoge für Batchbetrieb unterdrücken  
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    With Sheets(1)
        'nächste freie Zelle in Spalte A ermitteln  
        Set rngDest = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)  
        'Für jede Excel-Datei  
        For Each file In col
            'Workbook öffnen  
            Set wb = Workbooks.Open(file)
            'Range B20:B21 ins Sheet kopieren  
            wb.Sheets(1).Range("B20:B21").Copy rngDest  
            'WB schließen  
            wb.Close False
            'nächste freie Zelle setzen  
            Set rngDest = rngDest.Offset(2, 0)
        Next
    End With
    'Screenupdates und Dialoge wieder einschalten  
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Sub getAllFiles(ByVal fldr As Object, boolRecursion As Boolean, arrFileExtensions As Variant, ByRef col As Collection)
    For Each file In fldr.Files
        For i = 0 To UBound(arrFileExtensions)
            If LCase(arrFileExtensions(i)) = LCase(fso.GetExtensionName(file.Path)) Then
                col.Add file.Path
                Exit For
            End If
        Next
    Next
    If boolRecursion Then
        For Each subFolder In fldr.SubFolders
            getAllFiles subFolder, True, arrFileExtensions, col
        Next
    End If
End Sub

Grüße Uwe

Falls der Beitrag gefällt, seid so nett und unterstützt mich durch eine kleine Spende / If you like my contribution please support me and donate