AW: Dateinamen anpassen
24.08.2017 09:25:37
UweD
Hallo
so?
Option Explicit
Sub Dateien_umbenennen()
Dim Pfad As String, Datei As String
Dim Ext1 As String, Ext2 As String
Dim AltNam As String, NeuNam As String
Dim TB, i As Integer
Dim LR1 As Integer, LR2 As Integer
Pfad = "C:\Temp\Test\"
Ext1 = ".csv"
Ext2 = ".pdf"
Set TB = Sheets("Tabelle1")
TB.Cells.ClearContents
'* CSV Namen einlesen
Datei = Dir(Pfad & "*" & Ext1)
Do While Datei <> ""
If IsNumeric(Left(Datei, 1)) Then
MsgBox "Numerische CSV gefunden: " & Datei
Exit Sub
End If
i = i + 1
TB.Cells(i, 1) = Datei
Datei = Dir
Loop
i = 0
'* PDF Namen einlesen
Datei = Dir(Pfad & "*" & Ext2)
Do While Datei <> ""
If Not IsNumeric(Left(Datei, 1)) Then
MsgBox "Nichtnumerische PDF gefunden: " & Datei
Exit Sub
End If
i = i + 1
TB.Cells(i, 2) = Datei
Datei = Dir
Loop
'* prüfen auf gleiche Anzahl
LR1 = TB.Cells(TB.Rows.Count, 1).End(xlUp).Row
LR2 = TB.Cells(TB.Rows.Count, 2).End(xlUp).Row
If LR1 <> LR2 Then
MsgBox "ungleiche Anzahl"
Exit Sub
End If
'* Sortieren
With TB.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
.SetRange Range("A:A")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With TB.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("B1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
.SetRange Range("B:B")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'* Umbenennen
For i = 1 To LR1
AltNam = Pfad & TB.Cells(i, 1)
NeuNam = Pfad & Replace(TB.Cells(i, 2), Ext2, "") & Ext1
Name AltNam As NeuNam
Next
End Sub
LG UweD