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)
    2. 'Dim strVerzeichnis As String
    3. Dim StrDatei As String
    4. Dim StrTyp As String
    5. Dim objFileDialog As Office.FileDialog
    6. 'FolderPicker
    7. Set objFileDialog = Application.FileDialog(MsoFileDialogType.msoFileDialogFolderPicker)
    8. With objFileDialog
    9. .AllowMultiSelect = True
    10. .ButtonName = "Folder Picker"
    11. .Title = "Folder Picker"
    12. If (.Show > 0) Then
    13. End If
    14. If (.SelectedItems.Count > 0) Then
    15. ' Call MsgBox(.SelectedItems(1))
    16. strVerzeichnis = .SelectedItems(1)
    17. End If
    18. End With
    19. MsgBox (strVerzeichnis)
    20. End Sub
    21. Sub KontaktdatenAuslesen()
    22. Dim strVerzeichnis As String
    23. Dim Counter As Integer
    24. Dim Dateiname As String
    25. Dim wbQuelle As Workbook
    26. Dim wksQuelle As Worksheet
    27. Dim wbZiel As Workbook
    28. Dim wksZiel As Worksheet
    29. Dim strZiel As String, strPfadZiel As String
    30. Dim Zeile_Z As Long, Zelle_Letzte As Range
    31. Set wbZiel = ThisWorkbook
    32. Set wksZiel = wbZiel.Worksheets("Kontaktdaten")
    33. Counter = 0
    34. OrdnerAuswählen strVerzeichnis
    35. 'Alle Oefnnen
    36. Dateiname = Dir(strVerzeichnis & "\" & "Personalakte.xlsx")
    37. 'MsgBox (Dateiname)
    38. Do While Dateiname <> ""
    39. Set wbQuelle = Workbooks.Open(strVerzeichnis & "\" & Dateiname)
    40. Set wksQuelle = wbQuelle.Worksheets("Allgemein")
    41. 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
    51. 'Zellinhalte übertragen - nur Werte
    52. wksQuelle.Range("B12").Copy
    53. wksZiel.Cells(Zeile_Z, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    54. wksQuelle.Range("B5").Copy
    55. wksZiel.Cells(Zeile_Z, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    56. wksQuelle.Range("B1").Copy
    57. wksZiel.Cells(Zeile_Z, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    58. wksQuelle.Range("B2").Copy
    59. wksZiel.Cells(Zeile_Z, 4).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    60. wksQuelle.Range("B7").Copy
    61. wksZiel.Cells(Zeile_Z, 5).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    62. wksQuelle.Range("B8").Copy
    63. wksZiel.Cells(Zeile_Z, 6).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    64. wksQuelle.Range("B17").Copy
    65. wksZiel.Cells(Zeile_Z, 7).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    66. wksQuelle.Range("B16").Copy
    67. wksZiel.Cells(Zeile_Z, 8).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    68. wksQuelle.Range("B19").Copy
    69. wksZiel.Cells(Zeile_Z, 9).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    70. wksQuelle.Range("B20").Copy
    71. wksZiel.Cells(Zeile_Z, 10).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    72. wksQuelle.Range("B22").Copy
    73. wksZiel.Cells(Zeile_Z, 11).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    74. End With
    75. wbQuelle.Close savechanges:=False
    76. Counter = Counter + 1
    77. Dateiname = Dir
    78. Loop
    79. MsgBox (Counter & " Personalakten")
    80. 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
    3. Dim Fso As Object
    4. Dim Folder As Object
    5. Dim subfolders As Object
    6. Dim MyFile As String
    7. Dim wb As Workbook
    8. Dim wbZiel As Workbook
    9. Dim wksQuelle As Worksheet
    10. Dim wksZiel As Worksheet
    11. Dim Counter As Integer
    12. Dim CurrFile As Object
    13. With Application
    14. .ScreenUpdating = False
    15. .EnableEvents = False
    16. .Calculation = xlCalculationManual
    17. Dim Zeile_Z As Long, Zelle_Letzte As Range
    18. End With
    19. Set Fso = CreateObject("Scripting.FileSystemObject")
    20. Set Folder = Fso.GetFolder("C:\Users\aeckerro\Desktop\Test")
    21. Set subfolders = Folder.subfolders
    22. MyFile = "Personalakte.xlsx"
    23. Set wbZiel = ThisWorkbook
    24. Set wksZiel = wbZiel.Worksheets("Kontaktdaten_alle")
    25. Counter = 0
    26. For Each subfolders In subfolders
    27. Set CurrFile = subfolders.Files
    28. For Each CurrFile In CurrFile
    29. If CurrFile.Name = MyFile Then
    30. Set wb = Workbooks.Open(subfolders.Path & "\" & MyFile)
    31. Set wksQuelle = wb.Worksheets("Allgemein")
    32. With wksZiel
    33. 'Letze Zelle ermitteln
    34. Set Zelle_Letzte = .Cells.Find(What:="*", After:=Range("A1"), _
    35. LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByRows, _
    36. searchdirection:=xlPrevious)
    37. If Zelle_Letzte Is Nothing Then
    38. Zeile_Z = 1
    39. Else
    40. Zeile_Z = Zelle_Letzte.Row + 1
    41. End If
    42. 'Allgemeine Informationen
    43. wksQuelle.Range("B12").Copy
    44. wksZiel.Cells(Zeile_Z, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    45. wksQuelle.Range("B5").Copy
    46. wksZiel.Cells(Zeile_Z, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    47. wksQuelle.Range("B4").Copy
    48. wksZiel.Cells(Zeile_Z, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    49. wksQuelle.Range("B1").Copy
    50. wksZiel.Cells(Zeile_Z, 4).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    51. wksQuelle.Range("B2").Copy
    52. wksZiel.Cells(Zeile_Z, 5).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    53. wksQuelle.Range("B3").Copy
    54. wksZiel.Cells(Zeile_Z, 6).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    55. 'Aubildungen und Weiterbildungen
    56. '1.Ausbildung
    57. wksQuelle.Range("B7").Copy
    58. wksZiel.Cells(Zeile_Z, 7).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    59. wksQuelle.Range("B8").Copy
    60. wksZiel.Cells(Zeile_Z, 8).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    61. '1.Weiterbildung
    62. wksQuelle.Range("B29").Copy
    63. wksZiel.Cells(Zeile_Z, 9).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    64. wksQuelle.Range("B30").Copy
    65. wksZiel.Cells(Zeile_Z, 10).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    66. '2. Weiterbildung
    67. wksQuelle.Range("B37").Copy
    68. wksZiel.Cells(Zeile_Z, 11).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    69. wksQuelle.Range("B38").Copy
    70. wksZiel.Cells(Zeile_Z, 12).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    71. 'Persoenliche Informationen
    72. wksQuelle.Range("B17").Copy
    73. wksZiel.Cells(Zeile_Z, 13).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    74. wksQuelle.Range("B16").Copy
    75. wksZiel.Cells(Zeile_Z, 14).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    76. wksQuelle.Range("B19").Copy
    77. wksZiel.Cells(Zeile_Z, 15).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    78. wksQuelle.Range("B20").Copy
    79. wksZiel.Cells(Zeile_Z, 16).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    80. wksQuelle.Range("B22").Copy
    81. wksZiel.Cells(Zeile_Z, 17).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    82. wksQuelle.Range("G14").Copy
    83. wksZiel.Cells(Zeile_Z, 18).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    84. 'Auslesedatum einfügen
    85. wksZiel.Range("F1") = "Stand:" & Date
    86. End With
    87. wb.Close savechanges:=False
    88. Counter = Counter + 1
    89. End If
    90. Next
    91. Next
    92. Set Fso = Nothing
    93. Set Folder = Nothing
    94. Set subfolders = Nothing
    95. With Application
    96. .EnableEvents = True
    97. .Calculation = xlCalculationAutomatic
    98. .ScreenUpdating = True
    99. End With
    100. MsgBox (Counter & " Datensätze Übertragen")
    101. End Sub


    Danke schonmal

    Gruß Roman

    CodeTags korrigiert ~VaporiZed

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