Pfad abfragen

Hallo zusammen,
ich habe mir ein Makro gebastelt, welches alle Exceldateien in einem bestimmten Ordner nacheinander öffnet, jeweils bestimmte Werte entnimmt und in einer neuen Datei konsolidiert. Klappt auch alles super soweit.
Den Pfad zu den Exceldateien habe ich im Makro mit folgendem Befehl hinterlegt:
'Laufwerk und Pfad anpassen
ChDrive "C"
ChDir "C:\Documents and Settings\daten\"
strDatei = Dir("C:\Documents and Settings\daten\*.xls")
Da nicht jeder seine Daten dort speichert, wo ich das tue, hätte ich gerne eine Abfrage vorgeschaltet, die erfragt, in welchem Ordner die zu öffnenden Excel-Dateien liegen. Dieser Pfad soll dann in ChDir und strDatei übernommen werden.
Hat einer eine Ahnung, wie ich das anstellen kann?
Besten Dank und Gruß
Sascha

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub eingabe() Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll.", "Pfad _ definieren", _ "C:\Documents and Settings\daten") If Suchpfad = "" Then Exit Sub Dateiform = InputBox("Bitte die Endung der Dateiform definieren", "Dateierweiterung", "xls") If Dateiform = "" Then Exit Sub With Application.FileSearch .LookIn = Suchpfad .SearchSubFolders = True .Filename = Dateiform If .Execute() > 0 Then totFiles = .FoundFiles.Count For lngcount = 1 + a To totFiles varDateiname = .FoundFiles(lngcount) Next lngcount End If End With End Sub

Sub Alledateien_Bearbeiten() Dim strDatei As String Dim wb As Workbook Dim Ziel As Workbook Set Ziel = ThisWorkbook 'für Excel Zwischenspeicherung 'Laufwerk und Pfad anpassen ChDrive "C" ChDir "C:\Documents and Settings\SGAADMES1\My Documents\2_fortlaufend\Priority Accounts\" strDatei = Dir("C:\Documents and Settings\SGAADMES1\My Documents\2_fortlaufend\Priority _ Accounts\*.xls") Do While strDatei "" 'Öffnen erste Datei Set wb = Workbooks.Open(strDatei) 'Deine weiteren Befehle, zB. ActiveSheet.Outline.ShowLevels RowLevels:=2 Cells.Select Selection.SpecialCells(xlCellTypeVisible).Select Selection.Copy Windows("mysgm_vorlage.xlsm").Activate Sheets("Tabelle1").Select Range("A1").Select 'Ziel.Worksheets(1).Activate 'wechselt zur Zieldatei zurück Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Call auslesen_header Call kopieren_in_uebersicht Sheets("Tabelle1").Select Cells.ClearContents Selection.Delete 'Schliessen Datei wb.Close True 'Schauen, ob es noch weitere XLS-Dateien gibt strDatei = Dir Loop Set wb = Nothing Sheets("Übersicht").Select Range("E2:I20").Select Selection.NumberFormat = "#,##0" Selection.NumberFormat = "[$$-409]#,##0" Range("A1").Select End Sub

Sub Alledateien_Bearbeiten() Dim strDatei As String Dim wb As Workbook Dim Ziel As Workbook Dim vPfad As Variant Set Ziel = ThisWorkbook 'für Excel Zwischenspeicherung 'Laufwerk und Pfad anpassen With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Bitte Verzeichnis mit Dateien wählen" If .Show = -1 Then vPfad = .SelectedItems(1) Else Exit Sub End If End With ChDrive "C" ChDir vPfad strDatei = Dir(vPfad & "\*.xls") '....usw. End Sub

Hallo,
sorry hatte ich nicht mehr gesehen. Ich habe es mal versucht. Probier es mal so:

Sub Alledateien_Bearbeiten()
Dim strDatei As String, suchpfad As String, dateiform As String
Dim wb As Workbook
Dim Ziel As Workbook
Dim lngcount As Integer, totfiles As Integer
Set Ziel = ThisWorkbook 'für Excel Zwischenspeicherung
'Laufwerk und Pfad anpassen
suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll.", "Pfad _  _
definieren", "C:\Documents and Settings\SGAADMES1\My Documents\2_fortlaufend\Priority Accounts\")
If suchpfad = "" Then Exit Sub
dateiform = InputBox("Bitte die Endung der Dateiform definieren", "Dateierweiterung", "xls") _
If dateiform = "" Then Exit Sub
With Application.FileSearch
.LookIn = suchpfad
.SearchSubFolders = True
.Filename = dateiform
If .Execute() > 0 Then
totfiles = .FoundFiles.Count
For lngcount = 1 To totfiles
strDatei = .FoundFiles(lngcount)
Do While strDatei  ""
'Öffnen erste Datei
Set wb = Workbooks.Open(strDatei)
'Deine weiteren Befehle, zB.
ActiveSheet.Outline.ShowLevels RowLevels:=2
Cells.Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Windows("mysgm_vorlage.xlsm").Activate
Sheets("Tabelle1").Select
Range("A1").Select
'Ziel.Worksheets(1).Activate 'wechselt zur Zieldatei zurück
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Call auslesen_header
'Call kopieren_in_uebersicht
Sheets("Tabelle1").Select
Cells.ClearContents
Selection.Delete
'Schliessen Datei
wb.Close True
'Schauen, ob es noch weitere XLS-Dateien gibt
strDatei = Dir
Loop
Set wb = Nothing
Sheets("Übersicht").Range("E2:I20").NumberFormat = "#,##0"
Sheets("Übersicht").Range("E2:I20").NumberFormat = "[$$-409]#,##0"
Next lngcount
End If
End With
End Sub

Wichtig zu wissen ist noch, dass auch alle Unterordner durchsucht werden.
Gruß
welga

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Pfad abfragen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread