Makro auch in Unterordnern ausführen

Hallo zusammen,
ich bin der Neue. Meine Excelkenntnisse würde ich als gut bis sehr gut bezeichnen. Mit VBA habe ich zwar schon etwas herumgespielt, bin aber grundsätzlich gesehen noch Neuling. Inzwischen musste ich einsehen dass ein Buch lesen und im Internet suchen nicht ausreicht um VBA zu verstehen, daher werde ich im Mai einen Bildungsurlaub zum Thema Programmieren mit VBA antreten. Da ich mich unter anderem noch an DOS erinnern kann und mich darin auch gut zurecht gefunden habe ist bei mir ein gewisses Verständnis für Programmiersprachen vorhanden.
Jetzt zu meiner Frage:
Ich habe eine ganze Reihe von Dateien, in denen ich jeweils das erste Blatt umbenennen möchte. Mittels Makroaufzeichnung und einer Internetsuche habe ich mir ein funktionierendes Makro zusammengebastelt, das die Aufgabe erfüllt. Das Problem ist, dass ältere Dateien in verschiedenen Unterordnern abgelegt sind, das Makro bis jetzt aber nur im Hauptordner funktioniert. Da die im Netz gefundenen Lösungsansätze recht unterschiedlich sind, bin ich mir nicht sicher, wie ich den Code erweitern muss, um auch die Unterordner zu durchsuchen.
Da ich auch für statistische Auswertungen ein ähnliches Suchmuster benötige, wäre das die Grundlage für weitere Makros.
Wie muss ich folgenden Code ergänzen, um auch Unterordner zu durchsuchen?


Option Explicit
Sub Übersichtumbenennen()
' Übersichtumbenennen Makro
Dim strVerzeichnis As String
Dim StrDatei As String
Dim StrTyp As String
Dim Dateiname As String
strVerzeichnis = "Z:\XXXX_Labor\01 Prüfberichte (ausgefüllt)\"
StrTyp = "*WPK XXXX.xl*"
Dateiname = Dir(strVerzeichnis & StrTyp)
Do While Dateiname  ""
Workbooks.Open Filename:=strVerzeichnis & Dateiname
Sheets(1).Select
Sheets(1).Name = "Datenblatt WPK"
Range("G3").Select
ActiveWorkbook.Close True
Dateiname = Dir
Loop
End Sub

Gruß
Kai

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub UebersichtUmbenennen() Const BLATT_NAME_NEU$ = "Datenblatt WPK" Const DATEI_TYP$ = "*WPK XXXX.xl*" Const HAUPT_VERZEICHNIS$ = "Z:\XXXX_Labor\01 Prüfberichte (ausgefüllt)\" Dim oDatSys As Object, oOrdner As Object, oSubOrdner As Object Dim oDatei As Object, Stapel As Collection, Wb As Workbook Application.ScreenUpdating = False Set oDatSys = CreateObject("Scripting.FileSystemObject") Set Stapel = New Collection Stapel.Add oDatSys.GetFolder(HAUPT_VERZEICHNIS) Do While Stapel.Count > 0 Set oOrdner = Stapel(1) Stapel.Remove 1 For Each oSubOrdner In oOrdner.SubFolders Stapel.Add oSubOrdner Next oSubOrdner For Each oDatei In oOrdner.Files If oDatei.Name Like DATEI_TYP Then Set Wb = Workbooks.Open(oDatei.Path) With Wb .Worksheets(1).Name = BLATT_NAME_NEU: .Close True End With End If Next oDatei Loop End Sub

Sub Umbenennen() Dim oFolder As Object Dim strFolder As String Dim FSO As Object Application.ScreenUpdating = False With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Ordner wählen" .AllowMultiSelect = False If .Show = -1 Then strFolder = .SelectedItems(1) End If End With If strFolder = "" Then Exit Sub Set FSO = CreateObject("Scripting.FileSystemObject") Set oFolder = FSO.GetFolder(strFolder) prcFiles oFolder prcSubFolders oFolder End Sub Sub prcFiles(oFolder) Dim oFile As Object, wkb As Workbook For Each oFile In oFolder.Files If LCase(oFile) Like "*.xls*" Then Set wkb = Workbooks.Open(oFile) wkb.Sheets(1).Name = "Test" 'oder was du willst wkb.Close True End If Next End Sub Sub prcSubFolders(oFolder) Dim oSubFolder As Object For Each oSubFolder In oFolder.SubFolders prcFiles oSubFolder prcSubFolders oSubFolder Next End Sub

Option Explicit Sub WPKumbenennen2() Dim oFolder As Object Dim strFolder As String Dim FSO As Object Application.ScreenUpdating = False With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Ordner wählen" .AllowMultiSelect = False If .Show = -1 Then strFolder = .SelectedItems(1) End If End With If strFolder = "" Then Exit Sub Set FSO = CreateObject("Scripting.FileSystemObject") Set oFolder = FSO.GetFolder(strFolder) prcFiles oFolder prcSubFolders oFolder End Sub Sub prcFiles(oFolder) Dim oFile As Object, wkb As Workbook For Each oFile In oFolder.Files If LCase(oFile) Like "*WPK B*.xl*" Then Set wkb = Workbooks.Open(oFile) wkb.Sheets(1).Name = "Daten WPK" 'oder was du willst wkb.Close True End If Next End Sub Sub prcSubFolders(oFolder) Dim oSubFolder As Object For Each oSubFolder In oFolder.SubFolders prcFiles oSubFolder prcSubFolders oSubFolder Next End Sub

Beliebteste Forumthreads (12 Monate)

Makro auch in Unterordnern ausführen

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Makro auch in Unterordnern ausführen

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread