AW: Ordner automatisiert umbenennen
13.12.2016 13:00:03
Tino
Hallo,
hier mal eine Variante zum testen!
Option Explicit
Sub Beispiel()
Dim FSO As Object
Dim ArData, ArErg()
Dim sPath$
Dim n&
'Grund Pfad wo die Ordner sind
sPath = ThisWorkbook.Path
With Tabelle1 'Tabelle anpassen
If .Cells(.Rows.Count, 1).End(xlUp).Row < 5 Then Exit Sub
ArData = .Range("A5", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 2)
Redim ArErg(1 To Ubound(ArData), 1 To 1)
End With
sPath = IIf(Right$(sPath, 1) <> "\", sPath & "\", sPath)
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For n = 1 To Ubound(ArData)
If ArData(n, 1) <> "" Then 'Spalte A nicht leer
If ArData(n, 2) <> "" Then 'Spalte b nicht leer
If FSO.folderExists(sPath & ArData(n, 1)) Then 'Ordner Spalte A vorhanden
If Not FSO.folderExists(sPath & ArData(n, 1)) Then 'Ordner Spalte B nicht vorhanden
FSO.Getfolder(sPath & ArData(n, 1)).Move (sPath & ArData(n, 2))
If Err.Number <> 0 Then 'sonsige Fehler
ArErg(n, 1) = Err.Description
Err.Clear
Err.Number = 0
Else 'alles ok
ArErg(n, 1) = "ok"
End If
Else
ArErg(n, 1) = "Bereits vorhanden"
End If
Else
ArErg(n, 1) = "Ordner gibt es nicht"
End If
Else
ArErg(n, 1) = "Fehler Spalte B"
End If
Else
ArErg(n, 1) = "Fehler Spalte A"
End If
Next n
'Ausgabe Info
With Tabelle1
.Range("C5").Resize(Ubound(ArErg)) = ArErg
End With
End Sub
Gruß Tino