Dateien auf Laufwerk nach xls umbennen

Hi,
da meine VBA Kenntnisse schon sehr eingerostet sind und ich bei dieser Sache nichts falsch machen will frage ich doch mal lieber die Profis ;)
Ich würde gerne eine ganze Menge Daten anhand einer xls Datei umbennen.
Die xls ist folgend aufgebaut:
Spalte 1 = "Laufende Nummer"
Splate 3 = "Name"
Die Daten liegen alle auf einem Laufwerk (Z:) und sind einzeln in Ordnern mir der "Laufende Nummer" als Ordnername abgelegt. Die Dateiendung ist unterschiedlich und sollte beibehalten werden.
Am liebsten wäre es mir wenn man vor dem Durchlauf des Markos noch den zu bearbeitenden Bereich (von Zeile x bis y) einstellen kann.
Gibt es hierfür eine simple Lösung ?
P.S.: Ich habe auf den Rechner hier noch das gute alte Excel 2007 ;)
Vielen Dank schon mal für euren Input.
Flo

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub renameFiles() Dim strPath As String, strFile As String, strNew As String Dim lngRow As Long On Error Resume Next With Sheets("Tabelle1") 'Tabellenname - Anpassen For lngRow = 2 To Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row) strPath = "Z:\" & .Cells(lngRow, 1).Text If Right(strPath, 1) <> "\" Then strPath = strPath & "\" strFile = Dir(strPath & "*", vbNormal) If Len(strFile) Then strNew = .Cells(lngRow, 3) & Mid(strFile, InStrRev(strFile, ".")) Name strPath & strFile As strPath & strNew End If Next End With Err.Clear 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

Option Explicit Private Sub Umbenennen() On Error GoTo Fehler Dim TB1, i%, Von As Long, Bis As Long, Pfad As String Dim Datei As String, Neu As String, Ext As String Dim Sp As Integer, ZE As Integer, LR As Long, Z As Long '*** Stammdaten Anfang Set TB1 = ActiveSheet Pfad = "x:\Temp\Test\" Sp = 1 'Spalte A ZE = 1 'ab Zeile '*** Stammdaten Ende ' \ am Ende prüfen Pfad = IIf(Right(Pfad, 1) = "\", Pfad, Pfad & "\") 'Pfad prüfen If Dir(Pfad, vbDirectory) = "" Then MsgBox Pfad & ": existiert nicht" Exit Sub End If With TB1 LR = .Cells(.Rows.Count, Sp).End(xlUp).Row 'letzte Zeile der Spalte Von = InputBox("Ab Zeile", "Dateien umbenennen", ZE) Bis = InputBox("Bis Zeile", "Dateien umbenennen", LR) If Von > LR Or Bis > LR Or Von > Bis Then MsgBox "Angaben prüfen" Exit Sub End If 'Reset Kommentar .Columns(3).ClearContents For i = Von To Bis With .Cells(i, Sp) If .Value <> "" And .Offset(, 1) <> "" Then Datei = Dir(Pfad & .Value & ".*") 'Datei im Verz. finden If Datei <> "" Then Ext = Mid(Datei, InStrRev(Datei, ".")) 'Endung ermitteln Neu = .Offset(, 1) & Ext 'Neuer Name plus Endung 'umbenennen Name Pfad & Datei As Pfad & Neu 'Kommentar .Offset(, 2) = "umbenannt" Z = Z + 1 End If End If End With Next End With MsgBox Z & " Dateien umbenannt", vbExclamation '*** Fehlerbehandlung Err.Clear Fehler: Application.EnableEvents = True If Err.Number <> 0 Then MsgBox "Fehler: " & _ Err.Number & vbLf & Err.Description: Err.Clear End Sub

hab das mit den Unterverzeichnissen wohl falsch verstanden
hier die Änderung
Modul1

Option Explicit 
 
Private Sub Umbenennen() 
    On Error GoTo Fehler 
    Dim TB1, i%, Von As Long, Bis As Long, Pfad As String, UPfad As String 
    Dim Datei As String, Neu As String, Ext As String 
    Dim Sp As Integer, ZE As Integer, LR As Long, Z As Long, K As Integer 
     
    '*** Stammdaten Anfang 
    Set TB1 = ActiveSheet 
    Pfad = "x:\Temp\Test\" 
     
    Sp = 1 'Spalte A 
    ZE = 1 'ab Zeile 
    K = 4 ' Spalte für Kommentar 
    '*** Stammdaten Ende 
     
    ' \ am Ende prüfen 
    Pfad = IIf(Right(Pfad, 1) = "\", Pfad, Pfad & "\") 
     
    'Pfad prüfen 
    If Dir(Pfad, vbDirectory) = "" Then 
        MsgBox Pfad & ": existiert nicht" 
        Exit Sub 
    End If 
     
     
    With TB1 
        LR = .Cells(.Rows.Count, Sp).End(xlUp).Row 'letzte Zeile der Spalte 
         
        Von = InputBox("Ab Zeile", "Dateien umbenennen", ZE) 
        Bis = InputBox("Bis Zeile", "Dateien umbenennen", LR) 
             
        If Von > LR Or Bis > LR Or Von > Bis Then 
            MsgBox "Angaben prüfen" 
            Exit Sub 
        End If 
         
        'Reset Kommentar 
        .Columns(K).ClearContents 
         
        For i = Von To Bis 
                 
            With .Cells(i, Sp) 
                If .Value <> "" And .Offset(, 2) <> "" Then 
                    UPfad = .Value & "\" 
                    If Dir(Pfad & UPfad, vbDirectory) = "" Then 
                        MsgBox Pfad & UPfad & "    gibt es nicht" 
                        Exit Sub 
                    End If 
                     
                    Datei = Dir(Pfad & UPfad & "*.*") 'Datei im UnterVerz. finden 
                     
                    If Datei <> "" Then 
                        Ext = Mid(Datei, InStrRev(Datei, ".")) 'Endung ermitteln 
                        Neu = .Offset(, 2) & Ext 'Neuer Name plus Endung 
                         
                        'umbenennen 
                        Name Pfad & UPfad & Datei As Pfad & UPfad & Neu 
                         
                        'Kommentar 
                        .Cells(i, K) = "umbenannt" 
                        Z = Z + 1 
                    End If 
                End If 
            End With 
        Next 
     
    End With 
    MsgBox Z & "   Dateien umbenannt", vbExclamation 
     
    '*** Fehlerbehandlung 
    Err.Clear 
Fehler: 
    Application.EnableEvents = True 
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear 
End Sub

LG UweD

Beliebteste Forumthreads (12 Monate)

Dateien auf Laufwerk nach xls umbennen

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

	A	B	C	D	E	F
1	Gruß Sepp
2
3

	A	B	C	D	E	F
1	Gruß Sepp
2
3

Dateien auf Laufwerk nach xls umbennen

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread