AW: zusätzliche Elemente in Dateiname mit Makro
01.10.2015 07:19:30
fcs
Hallo Robert,
was soll ich noch erläutern?
Schau dir zu den einzelnen Funktionen die entsprechende Excel-VBA-Hilfe an.
Ansonsten werden im Hauptmakro in dem im Dialog ausgewählten Verzeichnis mit der Dir-Funktion die Excel-Dateien in einer Schleife gesucht und abgearbeitet.
In der der vom Hauptmakro aufgerufenen Funktion wird der alte Dateiname Zeichen für Zeichen nach dem von dir vorgegebene Schema in mehreren For-Next- und Do-Loop-Schleifen auf Zeichen und Ziffern analysiert und der neue Name zusammengebaut.
Lasst dir im VBA-Editor via Menü "Ansicht" das Fenster "Lokal" anzeigen und führe das Makro im Schrittmodus (mit Taste F8). Dann kannst du sehen, wie sich die Werte der Variablen während der Arbeit des Makros ändern.
Den fehlenden B-Wert kann man aus der Datei einlesen. Dazu muss die Datei jeweils kurz geöffnet werden. Hier musst du im angepassten Makro ggf. die Zelle mit dem Wert ändern. Der B-Wert wird dann in den alten Namen eingebaut, bevor die Anpassung der Ziffernfolgen erfolgt.
Gruß
Franz
Sub Dateien_umbenennen()
Dim varOrdner, varDatei, varOrdnerNeu
Dim strNeu$, iCount As Integer
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis mit den umzubenennenden Dateien auswählen"
If .Show = -1 Then
varOrdner = .SelectedItems(1)
Else
GoTo Beenden
End If
End With
varOrdnerNeu = varOrdner & "\Neu"
If Dir(varOrdnerNeu, vbDirectory) = "" Then
VBA.MkDir varOrdnerNeu
End If
varDatei = Dir(varOrdner & "\*.xls*", vbNormal)
Do Until varDatei = ""
iCount = iCount + 1
Application.StatusBar = " Datei Nr. " & Format(iCount, "0000") & " wird bearbeitet"
strNeu = fncNewName(varDatei, varOrdner)
VBA.FileCopy varOrdner & "\" & varDatei, varOrdnerNeu & "\" & strNeu
varDatei = Dir
Loop
Beenden:
Application.StatusBar = False
End Sub
Function fncNewName(ByVal strName As String, ByVal strPfad As String) As String
Dim Pos As Integer
Dim intL As Integer
Dim strOld As String, strDatei As String, strZahl As String
Dim wkb As Workbook, strB As String
'FLB4w01ms2a1ASus --> FLB004w01ms002a001Asus
'Fl_B5_W01_ms2_a1Asus --> FLB005w01ms002a001Asus
'HSW05S9A6AwgSOh --> HSB?W05S009A006AwgSOh
strOld = strName
If InStr(1, UCase(Left(strName, 4)), "B") = 0 Then
'fehlenden B-Wert aus Datei einlesen
With Application
.ScreenUpdating = False
.EnableEvents = False
Set wkb = Workbooks.Open(Filename:=strPfad & "\" & strName, _
ReadOnly:=True, UpdateLinks:=False)
strB = wkb.Worksheets(1).Range("A1").Text 'Zelle ggf. anpassen
wkb.Close savechanges:=False
' strOld = Left(strName, 2) & strB & Mid(strName, 3)
strOld = Left(strName, 2) & "B" & strB & Mid(strName, 3)
.ScreenUpdating = True
.EnableEvents = True
End With
End If
strDatei = ""
'B suchen
For Pos = 1 To Len(strOld)
If Mid(strOld, Pos, 1) "B" Then
If Mid(strOld, Pos, 1) "_" Then
strDatei = strDatei & UCase(Mid(strOld, Pos, 1))
End If
Else
strDatei = strDatei & "B"
Exit For
End If
Next
If Pos >= Len(strOld) Then GoTo Beenden
'Ziffernblock nach B ermitteln
strZahl = ""
Do
Pos = Pos + 1
If Not IsNumeric(Mid(strOld, Pos, 1)) Then
strDatei = strDatei & Format(Val(strZahl), "000")
If Mid(strOld, Pos, 1) "_" Then
strDatei = strDatei & Mid(strOld, Pos, 1)
End If
Exit Do
Else
strZahl = strZahl & Mid(strOld, Pos, 1)
End If
Loop Until Pos >= Len(strOld)
's suchen
For Pos = Pos + 1 To Len(strOld)
If LCase(Mid(strOld, Pos, 1)) "s" Then
If Mid(strOld, Pos, 1) "_" Then
strDatei = strDatei & Mid(strOld, Pos, 1)
End If
Else
strDatei = strDatei & Mid(strOld, Pos, 1) '"s"
Exit For
End If
Next
If Pos >= Len(strOld) Then GoTo Beenden
'Ziffernblock nach s ermitteln
strZahl = ""
Do
Pos = Pos + 1
If Not IsNumeric(Mid(strOld, Pos, 1)) Then
strDatei = strDatei & Format(Val(strZahl), "000")
If Mid(strOld, Pos, 1) "_" Then
strDatei = strDatei & Mid(strOld, Pos, 1)
End If
Exit Do
Else
strZahl = strZahl & Mid(strOld, Pos, 1)
End If
Loop Until Pos >= Len(strOld)
'a suchen
For Pos = Pos To Len(strOld)
If LCase(Mid(strOld, Pos, 1)) "a" Then
If Mid(strOld, Pos, 1) "_" Then
strDatei = strDatei & Mid(strOld, Pos, 1)
End If
Else
If LCase(Right(strDatei, 1)) "a" Then
strDatei = strDatei & Mid(strOld, Pos, 1)
End If
Exit For
End If
Next
If Pos >= Len(strOld) Then GoTo Beenden
'Ziffernblock nach a ermitteln
strZahl = ""
Do
Pos = Pos + 1
If Not IsNumeric(Mid(strOld, Pos, 1)) Then
strDatei = strDatei & Format(Val(strZahl), "000")
If Mid(strOld, Pos, 1) "_" Then
strDatei = strDatei & Mid(strOld, Pos, 1)
End If
Exit Do
Else
strZahl = strZahl & Mid(strOld, Pos, 1)
End If
Loop Until Pos >= Len(strOld)
If Pos >= Len(strOld) Then GoTo Beenden
'restliche Zeichen anfügen
strDatei = strDatei & Mid(strOld, Pos + 1)
Beenden:
fncNewName = strDatei
End Function