AW: Auslese und Umbenennung von Dateien
13.11.2013 19:57:51
Dateien
Hallo,
so habe mal noch was umgebaut.
Deine List sollte wie im Beispiel von Dir bereits sortiert sein.
Sub Start()
Dim ArFile(), ArNewFile(), ArListe()
Dim n&
Dim sDir$, sPath$, sName$, sX$
Dim tmpRow
'Extention der Datei
Const FileExt$ = ".DCM"
'Excelliste der Namen
With Tabelle1
ArListe = .Range("A4", .Cells(.Rows.Count, 1).End(xlUp)).Value2
End With
''Liste Sollte schon sortiert sein, sonst aktivieren
''evtl. passt die Zuordnung dann nicht wegen der Sortierreihenfolge Zahlen/Buchstaben
'QuickSort ArListe, 1, UBound(ArListe), 1
'Pfad angeben
sPath = "C:\TEMP\Neuer Ordner\"
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
sDir = Dir$(sPath & "*" & FileExt, vbNormal)
Do While sDir <> ""
n = n + 1
Redim Preserve ArFile(1 To n)
ArFile(n) = sDir
sDir = Dir$()
Loop
If n > 0 Then
Redim Preserve ArNewFile(1 To Ubound(ArFile), 1 To 3)
For n = Lbound(ArFile) To Ubound(ArFile)
ArNewFile(n, 1) = ArFile(n)
If InStr(ArFile(n), "_x") > 0 Then
'extrahiere Name ohne "_x..."
sName = Left(ArFile(n), InStrRev(ArFile(n), "_") - 1)
'Suche nach Name in Liste
tmpRow = Application.Match(sName & "*", ArListe, 0)
'gefunden?
If IsNumeric(tmpRow) Then
'extrahiere x für anzahl zu bestimmen
sX = Right$(ArFile(n), Len(ArFile(n)) - InStrRev(ArFile(n), "_"))
sX = Left$(sX, InStrRev(sX, ".") - 1)
If Len(sX) > 0 Then
tmpRow = tmpRow + Len(sX)
If tmpRow <= Ubound(ArListe) Then
If ArListe(tmpRow, 1) Like sName & "*" Then
ArNewFile(n, 2) = sName & "_" & Right$(ArListe(tmpRow, 1), _
Len(ArListe(tmpRow, 1)) - InStrRev(ArListe(tmpRow, 1), "_"))
ArNewFile(n, 2) = ArNewFile(n, 2) & FileExt
If Dir$(sPath & ArNewFile(n, 2)) = "" Then
'Datei umbenennen
Name (sPath & ArFile(n)) As (sPath & ArNewFile(n, 2))
ArNewFile(n, 3) = "ok"
Else
'Fehler Datei bereits vorhanden
ArNewFile(n, 3) = "Datei bereits vorhanden !!!"
End If
Else
ArNewFile(n, 3) = "kein passender Eintrag !!! Anzahl x = " & Len(sX)
End If
Else
ArNewFile(n, 3) = "kein passender Eintrag, Liste zu klein !!!"
End If
End If
Else
'keine Daten zum Textfile gefunden
ArNewFile(n, 3) = "keine Daten, Liste unvollständig?!"
End If
Else
ArNewFile(n, 3) = "nix gemacht, kein x im Namen!"
End If
Next n
Else
MsgBox "keine Textdatei gefunden"
Exit Sub
End If
'Ausgabe für Prüfung
If n > 0 Then
Application.ScreenUpdating = False
Application.EnableEvents = False
With ThisWorkbook
With .Sheets.Add(After:=.Sheets(.Sheets.Count))
.Cells(1, 1) = "alter Name"
.Cells(1, 2) = "neuer Name"
.Cells(1, 3) = "Info"
.Rows(1).Font.Bold = True
With .Range("A2").Resize(Ubound(ArNewFile), Ubound(ArNewFile, 2))
.Value = ArNewFile
.EntireColumn.AutoFit
End With
End With
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End If
End Sub
Sub QuickSort(ByRef sArray, ByVal StartUnten As Long, ByVal EndeOben As Long, _
ByVal LCol As Long, Optional ByVal Absteigend As Boolean = False)
Dim iUnten As Long, iOben, iMitte, y
Dim A As Long
iUnten = StartUnten
iOben = EndeOben
iMitte = sArray((StartUnten + EndeOben) / 2, LCol)
While (iUnten <= iOben)
If Not Absteigend Then
While (sArray(iUnten, LCol) < iMitte And iUnten < EndeOben)
iUnten = iUnten + 1
Wend
While (iMitte < sArray(iOben, LCol) And iOben > StartUnten)
iOben = iOben - 1
Wend
Else
While (sArray(iUnten, LCol) > iMitte And iUnten < EndeOben)
iUnten = iUnten + 1
Wend
While (iMitte > sArray(iOben, LCol) And iOben > StartUnten)
iOben = iOben - 1
Wend
End If
If (iUnten <= iOben) Then
For A = Lbound(sArray, 2) To Ubound(sArray, 2)
y = sArray(iUnten, A)
sArray(iUnten, A) = sArray(iOben, A)
sArray(iOben, A) = y
Next A
iUnten = iUnten + 1
iOben = iOben - 1
End If
Wend
If (StartUnten < iOben) Then Call QuickSort(sArray, StartUnten, iOben, LCol, Absteigend)
If (iUnten < EndeOben) Then Call QuickSort(sArray, iUnten, EndeOben, LCol, Absteigend)
End Sub
Gruß Tino