Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1308to1312
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro anpassen

Makro anpassen
17.04.2013 21:01:27
Lemmi
Hallo zusammen,
... ich habe von "Euch" ein schönes Makro bekommen!
Sub RenameFolder()
Dim oFS As Object, oFolder As Object
Dim sFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then sFolder = .SelectedItems(1)
End With
If sFolder  "" Then
Set oFS = CreateObject("Scripting.filesystemobject")
Set oFolder = oFS.getfolder(sFolder)
RenameSubFolder oFolder
If Len(oFolder.Name) > 6 Then
Name oFolder As _
Left(oFolder.Name, 6) _
& Replace(Mid(oFolder.Name, 7), "_", " ")
End If
End If
End Sub
Sub RenameSubFolder(oFolder As Object)
Dim oSubFolder As Object, oFile As Object
For Each oSubFolder In oFolder.subfolders
For Each oFile In oFolder.Files
If Len(oFile.Name) > 6 Then
Name oFile As oFile.Path _
& "\" & Left(oFile.Name, 6) _
& Replace(Mid(oFile.Name, 7), "_", " ")
End If
Next
RenameSubFolder oSubFolder
If Len(oSubFolder.Name) > 6 Then
Name oSubFolder As _
oFolder.Path & "\" _
& Left(oSubFolder.Name, 6) _
& Replace(Mid(oSubFolder.Name, 7), "_", " ")
End If
Next
End Sub

dieses Makro hat die "Aufgabe" ein selektiertes Verzeichnis und dessen Unterverzeichnisse sowie und dessen Datei- Namen zu Checken.
Es sollen die Verzeichniss - und Dateinamen wie folgt angepasst werden.
z. B. (alt)
Verzeichnisname:
01_000_mit viel Arbeit
Dateinamen:
01_002 Haus_123
02_001_Maus
03_005_Klaus_mit_der Maus ....
hier soll der Unterstrich nach der 6 Stelle entfernt werden.
(neu)
Verzeichnisname:
01_000 mit viel Arbeit
Dateinamen:
01_002 Haus 123
02_001 Maus
03_005 Klaus mit der Maus
Der Unterstrich an der dritten Stelle soll bleiben.
Ich bekomme immer ein Laufzeitfehler/ bzw. es werden nur die Verzeichnisnamen angepasst!
Vielen Dank im Voraus!
Gruß
Lemmi

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro anpassen
18.04.2013 01:42:41
Mustafa
Hallo Lemmi,
ungetestet würde ich sagen da ist ein kleiner fehler in dem Code, und zwar an dieser Stelle:
For Each oFile In oFolder.Files
sollte da nicht
For Each oFile In oSubFolder.Files
stehen ?
Rückmeldung obs Hilft wäre nett.
Gruß aus der Domstadt Köln.

Ordner und Dateien umbenennen
18.04.2013 01:51:05
Erich
Hi Lemmi,
da scheinen mir ein paar Schleifen durcheinander geraten zu sein.
So läuft es hoffentlich:

Option Explicit
Sub RenameFolder()
Dim oFS As Object, oFolder As Object, sFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then sFolder = .SelectedItems(1)
End With
If sFolder  "" Then
Set oFS = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFS.GetFolder(sFolder)
RenameSubFolder oFolder
If Len(oFolder.Name) > 6 Then
Name oFolder As Left(oFolder.Name, 6) _
& Replace(Mid(oFolder.Name, 7), "_", " ")
End If
End If
End Sub
Sub RenameSubFolder(oFolder As Object)
Dim oSubFo As Object, oFile As Object
For Each oFile In oFolder.Files
If Len(oFile.Name) > 6 Then
Name oFile As oFolder.Path & "\" & Left(oFile.Name, 6) _
& Replace(Mid(oFile.Name, 7), "_", " ")
End If
Next oFile
For Each oSubFo In oFolder.SubFolders
RenameSubFolder oSubFo
If Len(oSubFo.Name) > 6 Then
Name oSubFo As oFolder.Path & "\" & Left(oSubFo.Name, 6) _
& Replace(Mid(oSubFo.Name, 7), "_", " ")
End If
Next oSubFo
End Sub
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

Anzeige
AW: Ordner und Dateien umbenennen
18.04.2013 09:04:15
Lemmi
Hallo Erich,
alles bestens! vielen Dank!
Gruß
Lemmi

neue Version
18.04.2013 09:28:10
Erich
Hi Lemmi,
da war noch eine Unsicherheit drin. Wenn der Ordner z. B. C:\def\ghj\klmnopqr heißt, wird aus
Name sFolder As Left(oFolder.Name, 6) & Replace(Mid(oFolder.Name, 7), "_", " ")
die Anweisung
Name C:\def\ghj\klmnopqr As Left("klmnopqr_s", 6) & Replace(Mid("klmnopqr", 7), "_", " ")
oder
Name C:\def\ghj\klmnopqr As klmnopqr
Das funktioniert - warum auch immer.
Besser wäre aber wohl (auch nach der VBA-Hilfe), den neuen Namen mit vollständigem Pfad anzugeben, also
Name C:\def\ghj\klmnopqr As C:\def\ghj\klmnopqr
Neue Version:

Sub RenameFolder()
Dim oFS As Object, oFolder As Object, sFolder As String
Dim strNeu As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then sFolder = .SelectedItems(1)
End With
If sFolder  "" Then
Set oFS = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFS.GetFolder(sFolder)
RenameSubFolder oFolder
If Len(oFolder.Name) > 6 Then
If Not oFolder.IsRootFolder Then _
strNeu = oFolder.ParentFolder & "\"
Name sFolder As strNeu & Left(oFolder.Name, 6) _
& Replace(Mid(oFolder.Name, 7), "_", " ")
' oder
' oFS.MoveFolder sFolder, strNeu & Left(oFolder.Name, 6) _
& Replace(Mid(oFolder.Name, 7), "_", " ")
End If
End If
End Sub
Noch eins: Warum stellst du den Thread auf "offen"?
Das Gegenteil stimmt - deine Frage war doch beantwortet.
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige