Verzeichnisbaum nach Datei durchsuchen und bestimmte Zelle in eine andere Datei schreiben

  • Excel

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

    Verzeichnisbaum nach Datei durchsuchen und bestimmte Zelle in eine andere Datei schreiben

    Grüß Gott an Alle,
    hab schon geschätzte 3 std jetzt gegoogelt und dachte da richt ich mich an euch.
    Ich habe Folgendes Problem beim Makro schreiben:

    Es besteht aus einer Hauptdatei, welches eine Spalte B mit Dateinamen (z..b. Table_1.xls, Table_2.xls, ...) untereinander besitzt und links daneben eine leere Spalte A in die der Inhalt der Datei (Dateiname aus Spalte 1) kopiert werden soll.

    Beispiel: In der datei Hauptprogramm.xls steht in B2 Table_2.xls, nun soll das Programm nach der Datei Table_2.xls suchen, diese öffnen, den Wert z.b. aus Zelle A25 (ist in jeder Datei die gleiche Zelle) kopieren und ins Hauptprogramm nach A2 einfügen.

    Das ganze läuft in einer Schleife und arbeitet alle Dateinamen untereinander ab.

    Das klappt bis jetzt bei mir mit folgendem Code:

    Visual Basic-Quellcode

    1. Option Explicit
    3. Sub Makro1()
    5. 'Neues Excel Objekt anlegen
    6. 'um die zu betrachtende Exceldatei abzulegen
    8. Dim objExcel As New Excel.Application
    10. 'Sheet Objekt der jeweiligen Exceldatei anlegen
    11. Dim objSheet As Object
    13. 'Anlegen der Hilfsvariablen
    14. Dim iRow As Integer
    15. Dim strDateipfad As String
    16. Dim strPfad As String
    17. Dim strDateiname As String
    19. 'Pfad in welchem sich die Dateien der zu
    20. 'kopierenden Zellen sich befinden auswählen
    22. strPfad = "C:\VBA\Versuch1\"
    24. 'Schleife welche den Zelleninhalt aller aufgelisteten
    25. 'Dateien in mehrere Zellen des Hauptprogramms schreibt
    27. For iRow = 2 To 11
    29. 'Überprüfen, ob in Spalte "Dateiname" ein solcher eingetragen ist.
    30. 'Fals nicht, wird die Zeile mit einer Fehleranzeige übersprungen.
    31. '(der Arbeitsvorgang wird fortgesetzt)
    33. If Cells(iRow, 2) = "" Then
    35. MsgBox "Keinen Dateinamen gefunden, bitte Tabelle ergänzen. Arbeitsvorgang wird nun fortgesetzt. Inhalt fehlt in Zeile: " & iRow
    36. Cells(iRow, 3) = "X"
    37. Else
    40. strDateiname = Cells(iRow, 2)
    41. strDateipfad = strPfad & strDateiname
    43. 'Überprüfen, ob die in der Tabelle angegebene Datei vorhanden ist.
    44. 'fals nicht, wird die Zeile mit einer Fehleranzeige übersprungen.
    45. '(der Arbeitsvorgang wird fotzgesetzt)
    47. If Dir(strDateipfad) = "" Then
    48. MsgBox "Datei nicht gefunden, bitte vergewissern Sie sich ob die Datei " & strDateiname & " im jeweiligen Verzeichnis vorhanden ist. Arbeitsvorgang wird nun fortgesetzt"
    49. Cells(iRow, 3) = "X"
    50. Else
    51. objExcel.Workbooks.Open strDateipfad
    52. Set objSheet = objExcel.Sheets("Sheet1")
    53. Cells(iRow, 1) = objSheet.Cells(25, 1)
    54. Cells(iRow, 3) = "-"
    56. End If
    57. End If
    59. Next iRow
    61. 'Objekte (Mappe+Sheet) löschen
    62. 'Speicherdialog aufrufen
    64. objExcel.EnableEvents = False
    65. objExcel.DisplayAlerts = False
    67. objExcel.ActiveWorkbook.Close SaveChanges:=False
    68. objExcel.Quit
    70. Set objExcel = Nothing
    71. Set objSheet = Nothing
    73. Dim strDateinameNeu As String
    74. strDateinameNeu = "Tabelle mit Inhalt"
    76. Application.Dialogs(xlDialogSaveAs).Show "G:\030_Team\Support-Team\Students\Sprenger\" & strDateinameNeu
    78. End Sub


    So, nun ist meine Frage: Zur Zeit durchsucht mein Code nur das jeweils angegebene Verzeichnis. Ich will aber, dass z.b. in Verzeichnis A + Unterverzeichnis B + Unterverzeichnis C usw. nach der dementsprechenden Datei gesucht wird.


    Ich bedanke mich jetzt schon einmal, ihr seit meine letzte Hoffnung :D

    MfG Frizzle

    //EDIT: Da ich eine neuere Version als 2003 habe, ist mir nicht möglich die Applik. FileSearch zu benutzen

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

    Hallo,
    die Lösung liegt darin, den Code in eine Schleife zu packen, wo vor jedem Durchlauf von

    Visual Basic-Quellcode

    1. strDateipfad = strPfad & strDateiname
    strPfad angepasst wird.
    Gruß
    Peterfido

    Keine Unterstützung per PN!

    Geh rekursiv durch das Basisverzeichnis durch:

    Visual Basic-Quellcode

    1. Sub Main
    2. ExecuteFolder "c:\Versuch1", "*.xls"
    3. End Sub
    4. Sub ExecuteFolder (ByVal Foldername as String, ByVal Filter as String)
    5. Set FSO=CreateObject("Scripting.FileSystemObject")
    6. Set Folder=FSO.GetFolder(Foldername)
    7. For Each SubFolder in Folder.Folders
    8. ExecuteFolder SubFolder.Path, Filter
    9. Next
    10. For Each File in Folder.Files
    11. If File.Name Like Filter Then
    12. ExecuteFile File.Path
    13. Endif
    14. Next
    15. End Sub
    16. Sub ExecuteFile (ByVal Filename as String)
    17. ' tu was immer du willst mit der Datei
    18. End Sub
    Anmerkung:
    FSO musst du allerdings nicht unbedingt jedesmal neu erzeugen.
    Du kannst das CreateObject auch irgendwo global machen.
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

    Dieser Beitrag wurde bereits 2 mal editiert, zuletzt von „petaod“ ()

    also fals es jemanden interesiert, habe es nun ein bisschen anders geschafft.. und zwar lass ich mir alle Unterverzeichnisse in eine Spalte schreiben und überprüf dann jedes unterverzeichnis + das Hauptverzeichnis.

    Sieht dann so aus:

    Visual Basic-Quellcode

    1. Option Explicit
    3. Sub Makro1()
    5. Dim fs, f, f1, fc, s, i
    6. Set fs = CreateObject("Scripting.FileSystemObject")
    7. Set f = fs.GetFolder("C:\Versuch1\")
    8. Set fc = f.SubFolders
    10. i = 2
    11. For Each f1 In fc
    12. Cells(i, 6) = f1.Name & "\"
    13. i = i + 1
    14. Next
    16. 'Neues Excel Objekt anlegen
    17. 'um die zu betrachtende Exceldatei abzulegen
    19. Dim objExcel As New Excel.Application
    21. 'Sheet Objekt der jeweiligen Exceldatei anlegen
    22. Dim objSheet As Object
    24. 'Anlegen der Hilfsvariablen
    25. Dim iRow As Integer
    26. Dim strDateipfad As String
    27. Dim strPfad As String
    28. Dim strDateiname As String
    29. Dim iVerzeichnisse As Integer
    30. Dim strHauptpfad As String
    31. 'Pfad in welchem sich die Dateien der zu
    32. 'kopierenden Zellen sich befinden auswählen
    34. strHauptpfad = "C:\Versuch1\"
    36. 'Schleife welche den Zelleninhalt aller aufgelisteten
    37. 'Dateien in mehrere Zellen des Hauptprogramms schreibt
    39. For iRow = 2 To 11
    41. 'Überprüfen, ob in Spalte "Dateiname" ein solcher eingetragen ist.
    42. 'Fals nicht, wird die Zeile mit einer Fehleranzeige übersprungen.
    43. '(der Arbeitsvorgang wird fortgesetzt)
    45. If Cells(iRow, 2) = "" Then
    47. Cells(iRow, 3) = "X"
    49. Else
    52. For iVerzeichnisse = 2 To 5
    54. strPfad = strHauptpfad & Cells(iVerzeichnisse, 6)
    56. strDateiname = Cells(iRow, 2)
    57. strDateipfad = strPfad & strDateiname
    59. 'Überprüfen, ob die in der Tabelle angegebene Datei vorhanden ist.
    60. 'fals nicht, wird die Zeile mit einer Fehleranzeige übersprungen.
    61. '(der Arbeitsvorgang wird fotzgesetzt)
    63. If Dir(strDateipfad) = "" Then
    64. Cells(iRow, 3) = "X"
    65. Else
    66. objExcel.Workbooks.Open strDateipfad
    67. Set objSheet = objExcel.Sheets("Sheet1")
    68. Cells(iRow, 1) = objSheet.Cells(25, 1)
    69. Cells(iRow, 3) = "-"
    70. GoTo DateiGefunden
    71. End If
    74. Next iVerzeichnisse
    75. DateiGefunden:
    76. End If
    77. Next iRow
    79. 'Objekte (Mappe+Sheet) löschen
    80. 'Speicherdialog aufrufen
    82. objExcel.EnableEvents = False
    83. objExcel.DisplayAlerts = False
    85. objExcel.ActiveWorkbook.Close SaveChanges:=False
    86. objExcel.Quit
    88. Set objExcel = Nothing
    89. Set objSheet = Nothing
    91. Dim strDateinameNeu As String
    92. strDateinameNeu = "Tabelle mit Inhalt"
    94. Application.Dialogs(xlDialogSaveAs).Show "C:\Versuch1\" & strDateinameNeu
    96. End Sub



    Danke für eure Hilfe! :thumbsup:

Facebook
Telefonspende