AW: Dateien in Ordner umbenennen (Zellinhalt
24.11.2021 11:20:21
volti
Hallo Lkas,
hier noch mal ein Update u.a. auch mit etwas Fehlerabfang.
Hier kannst Du mal im Debug-Bereich prüfen, welche Dateien gefunden werden, welche einen Fehler produzieren und welche umbenannt werden.
Bei mir klappt es, aber ich habe ja auch nicht Deine Gegebenheiten...
Code:
[Cc][+][-]
Option Explicit
Dim gbUnterordner As Boolean, i As Long
Sub Umbenennen()
' Auflisten von gefilterten Dateien aus Ordner und Unterordner
Dim iAnz As Long, sArr() As String, sPath As String, vBB1 As Variant
sPath = "C:\Hier mussDeinOrdnerpfadrein" ' Pfad <<< anpassen >>>
gbUnterordner = True ' Mit Unterordner
FileOut_FSO iAnz, sArr, CreateObject("scripting.filesystemobject").GetFolder(sPath)
If iAnz > 0 Then
' Verarbeitung des Ergebnisses
For i = 1 To iAnz
vBB1 = GetValue(sArr(0, i) & "\", sArr(1, i), "Sheet1", "BB1")
If IsError(vBB1) Then
Debug.Print "In der Datei " & sArr(1, i) & " ist kein Blatt Sheet1 vorhanden!"
Else
sPath = sArr(0, i) & "\" & sArr(1, i)
Debug.Print "Name " & sPath & " AS " & Replace(sPath, ".xlsx", "_" & vBB1 & ".xlsx")
' Name sPath As Replace(sPath, ".xlsx", "_" & vBB1 & ".xlsx")' Verschieben = umbenennen!
End If
Next i
Else
' Keine Datei entsprechend des Suchbegriffes gefunden
MsgBox "Es wurden keine Dateien gefunden!", vbCritical, "Umbenennen"
End If
End Sub
Sub FileOut_FSO(i As Long, sArr, oPath As Object)
Dim oFile As Object, oDir As Object
On Error Resume Next
For Each oFile In oPath.Files ' Ordner durchsuchen
If Err = 0 Then
With oFile
Err = 0
If .Name Like "*.xlsx" Then
i = i + 1
ReDim Preserve sArr(1, i)
DoEvents
sArr(0, i) = Replace(.Path, "\" & .Name, "")
sArr(1, i) = .Name ' Dateiname ins Array aufnehmen
End If
End With
End If
Next
If gbUnterordner Then
For Each oDir In oPath.Subfolders ' Unterordner durchsuchen
FileOut_FSO i, sArr, oDir
Next
End If
End Sub
Private Function GetValue(ByVal sPath As String, ByVal sFile As String, _
ByVal sSheet As String, ByVal sTarget As String) As Variant
' Einen Wert aus einer Datei holen
On Error GoTo ErrorHandler
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
GetValue = ExecuteExcel4Macro("'" & sPath & "[" & sFile & "]" & sSheet & "'!" _
& Range(sTarget).Range("A1").Address(, , xlR1C1))
Exit Function
ErrorHandler:
GetValue = CVErr(xlErrRef)
End Function
viele Grüße
Karl-Heinz