Excel-Dateien aus Unterverzeichnissen auslesen

  • Excel

Es gibt 5 Antworten in diesem Thema. Der letzte Beitrag () ist von petaod.

    Excel-Dateien aus Unterverzeichnissen auslesen

    Moin moin,

    ich bräuchte da mal ein wenig Unterstützung.
    Habe nämlich von VBA gar keine Ahnung und habe von einem Kollegen (der sich auch nicht besonders auskennt) eine Datei samt Makro bekommen, die wie er sagt einfach & zusammen kopiert wurde.
    Mein Vorhaben ist, aus gleich aufgebauten Dateien (welche sich in verschiedenen Unterverzeichnissen befinden) Informationen auszulesen und diese in eine Datei als Übersicht zu packen.
    Das Makro funktioniert auch soweit, allerdings liest es immer nur das ausgewählte Verzeichnis aus OHNE Unterverzeichnisse.

    Könnt ihr mir da vielleicht weiterhelfen?

    Visual Basic-Quellcode

    1. Sub OrdnerAuswählen(strVerzeichnis As String)
    3. 'Dim strVerzeichnis As String
    4. Dim StrDatei As String
    5. Dim StrTyp As String
    6. Dim objFileDialog As Office.FileDialog
    9. 'FolderPicker
    10. Set objFileDialog = Application.FileDialog(MsoFileDialogType.msoFileDialogFolderPicker)
    12. With objFileDialog
    13. .AllowMultiSelect = True
    14. .ButtonName = "Folder Picker"
    15. .Title = "Folder Picker"
    16. If (.Show > 0) Then
    17. End If
    18. If (.SelectedItems.Count > 0) Then
    19. ' Call MsgBox(.SelectedItems(1))
    20. strVerzeichnis = .SelectedItems(1)
    21. End If
    22. End With
    24. MsgBox (strVerzeichnis)
    27. End Sub
    29. Sub KontaktdatenAuslesen()
    31. Dim strVerzeichnis As String
    33. Dim Counter As Integer
    34. Dim Dateiname As String
    35. Dim wbQuelle As Workbook
    37. Dim wksQuelle As Worksheet
    38. Dim wbZiel As Workbook
    39. Dim wksZiel As Worksheet
    40. Dim strZiel As String, strPfadZiel As String
    41. Dim Zeile_Z As Long, Zelle_Letzte As Range
    43. Set wbZiel = ThisWorkbook
    44. Set wksZiel = wbZiel.Worksheets("Kontaktdaten")
    46. Counter = 0
    48. OrdnerAuswählen strVerzeichnis
    50. 'Alle Oefnnen
    51. Dateiname = Dir(strVerzeichnis & "\" & "Personalakte.xlsx")
    53. 'MsgBox (Dateiname)
    55. Do While Dateiname <> ""
    57. Set wbQuelle = Workbooks.Open(strVerzeichnis & "\" & Dateiname)
    58. Set wksQuelle = wbQuelle.Worksheets("Allgemein")
    60. With wksZiel
    62. 'Letze Zelle ermitteln
    63. Set Zelle_Letzte = .Cells.Find(What:="*", After:=Range("A1"), _
    64. LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByRows, _
    65. searchdirection:=xlPrevious)
    66. If Zelle_Letzte Is Nothing Then
    67. Zeile_Z = 1
    68. Else
    69. Zeile_Z = Zelle_Letzte.Row + 1
    70. End If
    72. 'Zellinhalte übertragen - nur Werte
    73. wksQuelle.Range("B12").Copy
    74. wksZiel.Cells(Zeile_Z, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    75. wksQuelle.Range("B5").Copy
    76. wksZiel.Cells(Zeile_Z, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    77. wksQuelle.Range("B1").Copy
    78. wksZiel.Cells(Zeile_Z, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    79. wksQuelle.Range("B2").Copy
    80. wksZiel.Cells(Zeile_Z, 4).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    81. wksQuelle.Range("B7").Copy
    82. wksZiel.Cells(Zeile_Z, 5).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    83. wksQuelle.Range("B8").Copy
    84. wksZiel.Cells(Zeile_Z, 6).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    85. wksQuelle.Range("B17").Copy
    86. wksZiel.Cells(Zeile_Z, 7).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    87. wksQuelle.Range("B16").Copy
    88. wksZiel.Cells(Zeile_Z, 8).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    89. wksQuelle.Range("B19").Copy
    90. wksZiel.Cells(Zeile_Z, 9).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    91. wksQuelle.Range("B20").Copy
    92. wksZiel.Cells(Zeile_Z, 10).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    93. wksQuelle.Range("B22").Copy
    94. wksZiel.Cells(Zeile_Z, 11).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    97. End With
    99. wbQuelle.Close savechanges:=False
    101. Counter = Counter + 1
    104. Dateiname = Dir
    106. Loop
    108. MsgBox (Counter & " Personalakten")
    110. End Sub


    Vielen Dank schonmal.

    Liebe Grüße
    Roman

    CodeTags korrigiert ~VaporiZed

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „VaporiZed“ ()

    Roman483 schrieb:

    allerdings liest es immer nur das ausgewählte Verzeichnis aus OHNE Unterverzeichnisse.
    Der Trick ist:

    Visual Basic-Quellcode

    1. ​CreateObject("Scripting.FileSystemObject")
    und dann rekursiv durch die Verzeichnisse loopen.
    Im Forum gibt's Beispiele.
    Wenn du keine findest, gib Bescheid.
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

    Dankeschön.
    ich habe das versucht zu integrieren aber irgendwie will es nicht funktionieren.
    Er liest mir alle "Personalakten" aus dem angegebenen Verzeichnis und einer ebene darunter aus, er prüft aber nicht noch eine Ebene tiefer. Was habe ich falsch?

    Visual Basic-Quellcode

    1. Sub AllePersonalaktenuebertragen()
    2. ' Hier werden alle Personen ausgelesen
    4. Dim Fso As Object
    5. Dim Folder As Object
    6. Dim subfolders As Object
    7. Dim MyFile As String
    8. Dim wb As Workbook
    9. Dim wbZiel As Workbook
    10. Dim wksQuelle As Worksheet
    11. Dim wksZiel As Worksheet
    12. Dim Counter As Integer
    14. Dim CurrFile As Object
    15. With Application
    16. .ScreenUpdating = False
    17. .EnableEvents = False
    18. .Calculation = xlCalculationManual
    19. Dim Zeile_Z As Long, Zelle_Letzte As Range
    20. End With
    22. Set Fso = CreateObject("Scripting.FileSystemObject")
    23. Set Folder = Fso.GetFolder("C:\Users\aeckerro\Desktop\Test")
    24. Set subfolders = Folder.subfolders
    25. MyFile = "Personalakte.xlsx"
    26. Set wbZiel = ThisWorkbook
    27. Set wksZiel = wbZiel.Worksheets("Kontaktdaten_alle")
    28. Counter = 0
    30. For Each subfolders In subfolders
    32. Set CurrFile = subfolders.Files
    34. For Each CurrFile In CurrFile
    35. If CurrFile.Name = MyFile Then
    37. Set wb = Workbooks.Open(subfolders.Path & "\" & MyFile)
    38. Set wksQuelle = wb.Worksheets("Allgemein")
    40. With wksZiel
    42. 'Letze Zelle ermitteln
    43. Set Zelle_Letzte = .Cells.Find(What:="*", After:=Range("A1"), _
    44. LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByRows, _
    45. searchdirection:=xlPrevious)
    46. If Zelle_Letzte Is Nothing Then
    47. Zeile_Z = 1
    48. Else
    49. Zeile_Z = Zelle_Letzte.Row + 1
    50. End If
    53. 'Allgemeine Informationen
    54. wksQuelle.Range("B12").Copy
    55. wksZiel.Cells(Zeile_Z, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    56. wksQuelle.Range("B5").Copy
    57. wksZiel.Cells(Zeile_Z, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    58. wksQuelle.Range("B4").Copy
    59. wksZiel.Cells(Zeile_Z, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    60. wksQuelle.Range("B1").Copy
    61. wksZiel.Cells(Zeile_Z, 4).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    62. wksQuelle.Range("B2").Copy
    63. wksZiel.Cells(Zeile_Z, 5).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    64. wksQuelle.Range("B3").Copy
    65. wksZiel.Cells(Zeile_Z, 6).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    67. 'Aubildungen und Weiterbildungen
    68. '1.Ausbildung
    69. wksQuelle.Range("B7").Copy
    70. wksZiel.Cells(Zeile_Z, 7).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    71. wksQuelle.Range("B8").Copy
    72. wksZiel.Cells(Zeile_Z, 8).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    74. '1.Weiterbildung
    75. wksQuelle.Range("B29").Copy
    76. wksZiel.Cells(Zeile_Z, 9).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    77. wksQuelle.Range("B30").Copy
    78. wksZiel.Cells(Zeile_Z, 10).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    80. '2. Weiterbildung
    81. wksQuelle.Range("B37").Copy
    82. wksZiel.Cells(Zeile_Z, 11).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    83. wksQuelle.Range("B38").Copy
    84. wksZiel.Cells(Zeile_Z, 12).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    86. 'Persoenliche Informationen
    87. wksQuelle.Range("B17").Copy
    88. wksZiel.Cells(Zeile_Z, 13).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    89. wksQuelle.Range("B16").Copy
    90. wksZiel.Cells(Zeile_Z, 14).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    91. wksQuelle.Range("B19").Copy
    92. wksZiel.Cells(Zeile_Z, 15).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    93. wksQuelle.Range("B20").Copy
    94. wksZiel.Cells(Zeile_Z, 16).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    95. wksQuelle.Range("B22").Copy
    96. wksZiel.Cells(Zeile_Z, 17).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    97. wksQuelle.Range("G14").Copy
    98. wksZiel.Cells(Zeile_Z, 18).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    100. 'Auslesedatum einfügen
    101. wksZiel.Range("F1") = "Stand:" & Date
    103. End With
    104. wb.Close savechanges:=False
    105. Counter = Counter + 1
    107. End If
    110. Next
    113. Next
    117. Set Fso = Nothing
    118. Set Folder = Nothing
    119. Set subfolders = Nothing
    120. With Application
    121. .EnableEvents = True
    122. .Calculation = xlCalculationAutomatic
    123. .ScreenUpdating = True
    124. End With
    126. MsgBox (Counter & " Datensätze Übertragen")
    128. End Sub


    Danke schonmal

    Gruß Roman

    CodeTags korrigiert ~VaporiZed

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „VaporiZed“ ()

Facebook
Telefonspende