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 1 mit Dateinamen (z..b. Table_1.xls, Table_2.xls, ...) untereinander besitzt und rechts daneben eine leere Spalte 2 in die der Inhalt der Datei (Dateiname aus Spalte 1) kopiert werden soll.
Beispiel: In der datei Hauptprogramm.xls steht in A1 Table_1.xls, nun soll das Programm nach der Datei Table_1.xls suchen, diese öffnen, den Wert z.b. aus Zelle A25 (ist in jeder Datei die gleiche Zelle) kopieren und ins Hauptprogramm nach B1 einfügen.
Das klappt bis jetzt bei mir mit folgendem Code:
Option Explicit
Sub Makro1()
'Neues Excel Objekt anlegen
'um die zu betrachtende Exceldatei abzulegen
Dim objExcel As New Excel.Application
'Sheet Objekt der jeweiligen Exceldatei anlegen
Dim objSheet As Object
'Anlegen der Hilfsvariablen
Dim iRow As Integer
Dim strDateipfad As String
Dim strPfad As String
Dim strDateiname As String
'Pfad in welchem sich die Dateien der zu
'kopierenden Zellen sich befinden auswählen
strPfad = "G:\030_Team\Support-Team\Students\Sprenger\"
'Schleife welche den Zelleninhalt aller aufgelisteten
'Dateien in mehrere Zellen des Hauptprogramms schreibt
For iRow = 2 To 11
'Überprüfen, ob in Spalte "Dateiname" ein solcher eingetragen ist.
'Fals nicht, wird die Zeile mit einer Fehleranzeige übersprungen.
'(der Arbeitsvorgang wird fortgesetzt)
If Cells(iRow, 2) = "" Then
MsgBox "Keinen Dateinamen gefunden, bitte Tabelle ergänzen. Arbeitsvorgang wird nun fortgesetzt. Inhalt fehlt in Zeile: " & iRow
Cells(iRow, 3) = "X"
Else
strDateiname = Cells(iRow, 2)
strDateipfad = strPfad & strDateiname
'Überprüfen, ob die in der Tabelle angegebene Datei vorhanden ist.
'fals nicht, wird die Zeile mit einer Fehleranzeige übersprungen.
'(der Arbeitsvorgang wird fotzgesetzt)
If Dir(strDateipfad) = "" Then
MsgBox "Datei nicht gefunden, bitte vergewissern Sie sich ob die Datei " & strDateiname & " im jeweiligen Verzeichnis vorhanden ist. Arbeitsvorgang wird nun fortgesetzt"
Cells(iRow, 3) = "X"
Else
objExcel.Workbooks.Open strDateipfad
Set objSheet = objExcel.Sheets("Sheet1")
Cells(iRow, 1) = objSheet.Cells(25, 1)
Cells(iRow, 3) = "-"
End If
End If
Next iRow
'Objekte (Mappe+Sheet) löschen
'Speicherdialog aufrufen
objExcel.EnableEvents = False
objExcel.DisplayAlerts = False
objExcel.ActiveWorkbook.Close SaveChanges:=False
objExcel.Quit
Set objExcel = Nothing
Set objSheet = Nothing
Dim strDateinameNeu As String
strDateinameNeu = "Tabelle mit Inhalt"
Application.Dialogs(xlDialogSaveAs).Show "G:\030_Team\Support-Team\Students\Sprenger\" & strDateinameNeu
End Sub
So, nun ist meine Frage: Wie kann ich dieses Programm erweitern, dass es mir nicht nur den angegebenen Pfad sondern auch alle Ordner in diesem Pfad nach dem Dateinamen durchsucht?
|