zusätzliche Elemente in Dateiname mit Makro

Bild

Betrifft: zusätzliche Elemente in Dateiname mit Makro
von: Robert
Geschrieben am: 25.09.2015 12:36:35

Hallo, ich habe folgende Probleme
1. ich habe exceldateien mit Folgender Form FLB4w01ms2a1ASus
- ich würde gern zusätzliche elemente einfügen mit hilfe eines makros.
- Hinter dem B,s und a soll nicht nur eine Zahl stehen sondern 3, wobei das Makro erkennen soll wie viele zahlen dort stehen (Bsp.: FLB001w01ms002a001Asus)
2. leider sehen einige dateien so aus Fl_B5_W01_ms2_a1Asus
ich würde sie gern in die gewünschte form von oben bringen (Bsp.: FLB001w01ms002a001Asus)
tw. besitzen diese Dateien die letzten Buchstaben nicht bzw es sind mehr oder weniger, diese müssen jedoch falls vorhanden immer erhalten bleiben im Namen.
ich würde mich über 2 kleine quellcodes mit einer kurzen erläuterung sehr freuen.
diese sache ist notwendig da es sich um mehrere tausend dateien handelt
Viele Grüße
Robert

Bild

Betrifft: AW: zusätzliche Elemente in Dateiname mit Makro
von: fcs
Geschrieben am: 25.09.2015 15:08:57
Hallo Robert,
von mir gibt es nur ein Makro,
das beide Namens-Varianten abarbeitet.
Du wählst im angezeigten Dialog den Ordner mit den Dateien aus, die umbenannt werden sollen.
Das Makro legt dann einen Unterordner an, in den die Dateien mit dem neuen Namen kopiert werden.
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)
    VBA.FileCopy varOrdner & "\" & varDatei, varOrdnerNeu & "\" & strNeu
    varDatei = Dir
  Loop
Beenden:
  Application.StatusBar = False
End Sub
Function fncNewName(ByVal strName As String) As String
  Dim Pos As Integer
  Dim intL As Integer
  Dim strOld As String, strDatei As String, strZahl As String
  'FLB4w01ms2a1ASus     --> FLB004w01ms002a001Asus
  'Fl_B5_W01_ms2_a1Asus --> FLB005w01ms002a001Asus
  strOld = strName
  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 Mid(strOld, Pos, 1) <> "s" Then
      If Mid(strOld, Pos, 1) <> "_" Then
        strDatei = strDatei & Mid(strOld, Pos, 1)
      End If
    Else
      strDatei = strDatei & "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 Mid(strOld, Pos, 1) <> "a" Then
      If Mid(strOld, Pos, 1) <> "_" Then
        strDatei = strDatei & Mid(strOld, Pos, 1)
      End If
    Else
      If 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


Bild

Betrifft: AW: zusätzliche Elemente in Dateiname mit Makro
von: Robert
Geschrieben am: 30.09.2015 17:00:57
Danke dir:) könntest du mir den quelltest etwas im detail bitte erklären.
ich habe einen dritten dateityp gefunden der folgendermaßen aussieht:HSW05S9A6AwgSOh. funktioniert es dafür auch? das fehlende b steht in der Datei drin, kann man dies wie rausziehen und in den Namen implementieren?

Bild

Betrifft: AW: zusätzliche Elemente in Dateiname mit Makro
von: fcs
Geschrieben am: 01.10.2015 07:19:30
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


Bild

Betrifft: AW: zusätzliche Elemente in Dateiname mit Makro
von: Robert
Geschrieben am: 01.10.2015 10:45:18
HAt super geklappt, besten dank:)

 Bild

Beiträge aus den Excel-Beispielen zum Thema "zusätzliche Elemente in Dateiname mit Makro"