AW: Ordner, Unterordner, Dateien finden und umbenennen
20.09.2018 18:59:34
Sepp
Hallo Ete,
nur quick!
Modul Modul1
Option Explicit
Sub renaming()
Dim strInitalPath As String, strSearch As String, strReplace As String
On Error GoTo Errorhandler1
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Bitte Ordner wählen"
.InitialFileName = ThisWorkbook.Path
.InitialView = msoFileDialogViewThumbnail
.ButtonName = "select"
If .Show = -1 Then
strInitalPath = .SelectedItems(1)
End If
End With
If Len(strInitalPath) Then
strSearch = frmCOMNO.ldnmb.Value
strReplace = frmCOMNO.nwnb.Value
Call renameFilesAndFolders(strInitalPath, strSearch, strReplace)
MsgBox "Renaming finalized"
End If
Errorhandler1:
If Err.Number <> 0 Then MsgBox "Error: Please contact SF2T Support."
End Sub
Sub renameFilesAndFolders(StartFolder As String, sSearch As String, sReplace As String)
Dim objFSO As Object, objFolder As Object, objSFolder As Object, objFile As Object
Dim strNewName As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(StartFolder)
For Each objSFolder In objFolder.SubFolders
For Each objFile In objSFolder.Files
If objFile.Name Like "*" & sSearch & "*" Then
strNewName = objFile.ParentFolder.Path & "\" & Replace(objFile.Name, sSearch, sReplace)
objFSO.MoveFile objFile.Path, strNewName
End If
Next
If objSFolder.Name Like "*" & sSearch & "*" Then
strNewName = objSFolder.ParentFolder.Path & "\" & Replace(objSFolder.Name, sSearch, _
sReplace)
objFSO.MoveFolder objSFolder.Path, strNewName
Else
strNewName = objSFolder.Path
End If
For Each objFile In objFolder.Files
If objFile.Name Like "*" & sSearch & "*" Then
strNewName = objFile.ParentFolder.Path & "\" & Replace(objFile.Name, sSearch, sReplace)
objFSO.MoveFile objFile.Path, strNewName
End If
Next
If objFolder.Name Like "*" & sSearch & "*" Then
strNewName = objFolder.ParentFolder.Path & "\" & Replace(objFolder.Name, sSearch, _
sReplace)
objFSO.MoveFolder objFolder.Path, strNewName
End If
Call renameFilesAndFolders(strNewName, sSearch, sReplace)
Next
Set objFSO = Nothing
Set objFolder = Nothing
Set objSFolder = Nothing
Set objFile = Nothing
End Sub
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0