AW: Pfad abfragen
04.03.2010 08:22:22
welga
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