Auslesen von Dateien

nach unten

Betrifft: Auslesen von Dateien
von: Björn
Geschrieben am: 10.05.2021 14:16:35

Hallo,
ich habe ein Makro Dies habe ich mal aus diesem Forum bekommen.
Dies funktioniert auch. Es geht alle Excel-Dateien im Zielpfad duch und gibt mir definierte Felder wieder. Somit habe ich aus vielen Einzeldateien dann eine Gesamtdatei/ -liste.
Nun hab ich 2 Fragen an euch:
1. Die auszulesenden Dateien haben hier immer das Tabellenblatt "Vorlage" aus dem dann die Felder gezogen werden. Nun habe ich auch viele Dateien, die vielleicht Vorlage1, Übersicht, oder Tabelle1 heißen. Wie kann ich es umschreiben, dass er alle Tabellenblätter der Datei zieht und auswertet?
2. Der Ort der auszulesenden Dateien ist ein Ordner. Unterordner werden nicht einbezogen. Wie kann ich es umschreiben, dass er den Ordner und alle Unterordner mit einbezieht?
Danke euch.
Option Explicit

Public Sub ExcelDateienAuswerten()

    Dim strDateiname As String
    Dim strPfad      As String
    Dim lngZeile     As Long
    
    'Pfadangabe, in dem die zu lesenden Excel-Datei (*.xlsx) liegen
    strPfad = "G:\Maßnahmen\"
    
    'Den 1. Dateinamen holen
    strDateiname = Dir(strPfad & "*.xlsx")

    'Startzeile festlegen
    lngZeile = 4
    
    'Solange ein Dateiname gelesen wird
    Do While Not strDateiname = ""
        
        'Datei verarbeiten
        Call TabVerarb(strPfad & strDateiname, lngZeile)
        
        'nächsten Dateinamen holen
        strDateiname = Dir()
        
        'Zeilenzähler erhöhen
        lngZeile = lngZeile + 1
     Loop

End Sub
Public Sub TabVerarb(strPfad As String, lngZeile As Long)
    Dim strMeSH As String
    Dim strDatei As String
    Dim strSH As String
    
    'Dateinamen extrahieren
    strDatei = Split(strPfad, "\")(UBound(Split(strPfad, "\")))
    
    'Eigenen Namen merken
    strMeSH = ActiveWorkbook.Name
    
    'Datei öffnen
    Workbooks.Open Filename:=strPfad
    
    With Workbooks(strMeSH)
        'Dateinamen und auszuwertenden Zellen übertragen
        .Sheets("Tabelle1").Cells(lngZeile, 1) = strDatei
        .Sheets("Tabelle1").Cells(lngZeile, 2) = Workbooks(strDatei).Sheets("Vorlage").Range("G4").Value
        .Sheets("Tabelle1").Cells(lngZeile, 3) = Workbooks(strDatei).Sheets("Vorlage").Range("B4").Value
        .Sheets("Tabelle1").Cells(lngZeile, 4) = Workbooks(strDatei).Sheets("Vorlage").Range("G7").Value
        .Sheets("Tabelle1").Cells(lngZeile, 5) = Workbooks(strDatei).Sheets("Vorlage").Range("B2").Value
        .Sheets("Tabelle1").Cells(lngZeile, 6) = Workbooks(strDatei).Sheets("Vorlage").Range("B28").Value
        .Sheets("Tabelle1").Cells(lngZeile, 7) = Workbooks(strDatei).Sheets("Vorlage").Range("G28").Value
        .Sheets("Tabelle1").Cells(lngZeile, 8) = Workbooks(strDatei).Sheets("Vorlage").Range("B45").Value
        .Sheets("Tabelle1").Cells(lngZeile, 9) = Workbooks(strDatei).Sheets("Vorlage").Range("B49").Value
        .Sheets("Tabelle1").Cells(lngZeile, 10) = Workbooks(strDatei).Sheets("Vorlage").Range("C45").Value
        .Sheets("Tabelle1").Cells(lngZeile, 11) = Workbooks(strDatei).Sheets("Vorlage").Range("C49").Value
        .Sheets("Tabelle1").Cells(lngZeile, 12) = Workbooks(strDatei).Sheets("Vorlage").Range("D45").Value
        .Sheets("Tabelle1").Cells(lngZeile, 13) = Workbooks(strDatei).Sheets("Vorlage").Range("E45").Value
        .Sheets("Tabelle1").Cells(lngZeile, 14) = Workbooks(strDatei).Sheets("Vorlage").Range("E49").Value
        .Sheets("Tabelle1").Cells(lngZeile, 15) = Workbooks(strDatei).Sheets("Vorlage").Range("F45").Value
        .Sheets("Tabelle1").Cells(lngZeile, 16) = Workbooks(strDatei).Sheets("Vorlage").Range("F49").Value
        .Sheets("Tabelle1").Cells(lngZeile, 17) = Workbooks(strDatei).Sheets("Vorlage").Range("G45").Value
        .Sheets("Tabelle1").Cells(lngZeile, 18) = Workbooks(strDatei).Sheets("Vorlage").Range("G49").Value
        .Sheets("Tabelle1").Cells(lngZeile, 19) = Workbooks(strDatei).Sheets("Vorlage").Range("H45").Value
        .Sheets("Tabelle1").Cells(lngZeile, 20) = Workbooks(strDatei).Sheets("Vorlage").Range("H49").Value
    End With
    
    'Quelldatei schließen
    Workbooks(strDatei).Saved = True
    Workbooks(strDatei).Close

End Sub

nach oben  nach unten

Betrifft: AW: Auslesen von Dateien
von: Nepumuk
Geschrieben am: 10.05.2021 15:48:42
Hallo Björn,
teste mal:
Code:

[Cc][+][-]

Option Explicit Public Sub ExcelDateienAuswerten() Const FOLDER_PATH As String = "G:\Maßnahmen\" Dim astrFolders() As String, strFilename As String Dim ialngFolders As Long, lngRow As Long ' Startzeile festlegen lngRow = 4 ' Ordner und alle Unterordner holen astrFolders = GetFolders(FOLDER_PATH) ' Schleife über über Ordner For ialngFolders = LBound(astrFolders) To UBound(astrFolders) ' Den 1. Dateinamen des Ordners holen strFilename = Dir$(astrFolders(ialngFolders) & "*.xlsx") ' Solange ein Dateiname gelesen wird Do Until strFilename = vbNullString ' Datei verarbeiten Call CopyValues(astrFolders(ialngFolders) & strFilename, lngRow) ' nächsten Dateinamen holen strFilename = Dir$ Loop Next End Sub Private Sub CopyValues(ByVal pvstrPath As String, ByRef prlngRow As Long) Dim objWorkbook As Workbook Dim objWorksheet As Worksheet ' Datei öffnen Set objWorkbook = Workbooks.Open(Filename:=pvstrPath) ' Schleife über alle Tabellen For Each objWorksheet In objWorkbook.Worksheets With ThisWorkbook.Worksheets("Tabelle1") ' Dateinamen und auszuwertenden Zellen übertragen .Cells(prlngRow, 1).Value = objWorkbook.Name .Cells(prlngRow, 2).Value = objWorksheet.Range("G4").Value .Cells(prlngRow, 3).Value = objWorksheet.Range("B4").Value .Cells(prlngRow, 4).Value = objWorksheet.Range("G7").Value .Cells(prlngRow, 5).Value = objWorksheet.Range("B2").Value .Cells(prlngRow, 6).Value = objWorksheet.Range("B28").Value .Cells(prlngRow, 7).Value = objWorksheet.Range("G28").Value .Cells(prlngRow, 8).Value = objWorksheet.Range("B45").Value .Cells(prlngRow, 9).Value = objWorksheet.Range("B49").Value .Cells(prlngRow, 10).Value = objWorksheet.Range("C45").Value .Cells(prlngRow, 11).Value = objWorksheet.Range("C49").Value .Cells(prlngRow, 12).Value = objWorksheet.Range("D45").Value .Cells(prlngRow, 13).Value = objWorksheet.Range("E45").Value .Cells(prlngRow, 14).Value = objWorksheet.Range("E49").Value .Cells(prlngRow, 15).Value = objWorksheet.Range("F45").Value .Cells(prlngRow, 16).Value = objWorksheet.Range("F49").Value .Cells(prlngRow, 17).Value = objWorksheet.Range("G45").Value .Cells(prlngRow, 18).Value = objWorksheet.Range("G49").Value .Cells(prlngRow, 19).Value = objWorksheet.Range("H45").Value .Cells(prlngRow, 20).Value = objWorksheet.Range("H49").Value End With ' Zeilenzähler erhöhen prlngRow = prlngRow + 1 Next ' Quelldatei schließen Call objWorkbook.Close(SaveChanges:=False) ' Objekt freigeben Set objWorkbook = Nothing End Sub Private Function GetFolders(ByVal pvstrPath As String) As String() Dim astrFolders() As String Dim strFolder As String, strPath As String Dim ialngIndex1 As Long, ialngIndex2 As Long ReDim Preserve astrFolders(ialngIndex1) astrFolders(ialngIndex1) = pvstrPath ialngIndex1 = 1 ialngIndex2 = 1 strPath = pvstrPath Do strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory) Do Until strFolder = vbNullString If strFolder <> "." And strFolder <> ".." Then If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then ReDim Preserve astrFolders(0 To ialngIndex1) astrFolders(ialngIndex1) = strPath & strFolder & "\" ialngIndex1 = ialngIndex1 + 1 End If End If strFolder = Dir$ Loop If ialngIndex1 = ialngIndex2 Then Exit Do strPath = astrFolders(ialngIndex2) ialngIndex2 = ialngIndex2 + 1 Loop GetFolders = astrFolders End Function

Gruß
Nepumuk

nach oben  nach unten

Betrifft: AW: Auslesen von Dateien
von: Björn
Geschrieben am: 10.05.2021 16:11:27
Hallo Nepumuk,
Danke für deine Hilfe. Ich habe versucht zu verstehen was du machst. Ich bin leider Laie, aber zumindest kann ich es grob nachvollziehen.
Ich habe es getestet und es funktioniert tadellos. ZUmindest mit meinen Beipsieldateien.
Morgen werde ich es ausführlich testen.
Danke dir vielmals.

Excel-Beispiele zum Thema "Auslesen von Dateien"