Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1576to1580
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Dateinamen anpassen

Dateinamen anpassen
24.08.2017 08:18:47
Jens
Hallo,
ich würde gerne per Button ein Menü öffnen lassen aus dem ich Ordner auswählen kann.
z.B. über
Datei = Application.GetOpenFilename
In dem ausgewählten Ordner liegen dann Dateien.
z.b
12345.pdf
23456.pdf
34567.pdf
a.csv
b.csv
c.csv
Nun soll es so sein, dass nach Auswahl des Ordners die Datei a.cvs den Namen 12345.csv bekommt usw.
Wie löst man so was? die Zordnung soll so erfolgen, dass die erste alphabetische pdf Datei mit der ersten afphabetischen cvs Datei namentlich zum Schluss zusammenpasst.

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
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
Anzeige
AW: Dateinamen anpassen
24.08.2017 09:51:51
Jens
Hallo,
danke.
Der Ordner sollte aber auswählbar sein.
Das zweite was ich nicht verstehe: Bei mir kommt nun die Meldung.
Nummerische CVS gefunden: 1.cvs
dann wird weiter nichts gemacht.
Also die Dateinamen müssen nicht so aufgebaut sein können auch Texte sein. (sowohl pdf als auch cvs)
Liegt es vllt. daran?
AW: Dateinamen anpassen
24.08.2017 09:54:01
Jens
Hallo,
danke.
Der Ordner sollte aber auswählbar sein.
Das zweite was ich nicht verstehe: Bei mir kommt nun die Meldung.
Nummerische CVS gefunden: 1.cvs
dann wird weiter nichts gemacht.
Wenn die CVS- Datei a.cvs heisst dann geht es... es kann aber auch eine Zahl sein.
Also die Dateinamen müssen nicht so aufgebaut sein können auch Texte sein. (sowohl pdf als auch cvs)
Liegt es vllt. daran?
Anzeige
AW: Dateinamen anpassen
24.08.2017 10:05:27
UweD
Ok, dann die Abfrage nach "Numerische CSV" raus.
Aber Nur Numerische PDFs vorhanden ?
sonst analog dort auch raus
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 = ActiveWorkbook.Sheets.Add
    
    '* CSV Namen einlesen 
    Datei = Dir(Pfad & "*" & Ext1)
    Do While Datei <> ""
        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
    Application.DisplayAlerts = False
    TB.Delete
    Application.DisplayAlerts = True
    
End Sub

LG UweD
Anzeige
AW: Dateinamen anpassen
24.08.2017 10:15:04
UweD
Ah, jetzt hab ich es verstanden
es ist also egal, wie die CSV vorher heißen.
Dann kann auch evtl. ja auch die Sortierung raus.
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 = ActiveWorkbook.Sheets.Add
    
    '* CSV Namen einlesen 
    Datei = Dir(Pfad & "*" & Ext1)
    Do While Datei <> ""
        i = i + 1
        TB.Cells(i, 1) = Datei
        Datei = Dir
    Loop
    i = 0
        
    '* PDF Namen einlesen 
    Datei = Dir(Pfad & "*" & Ext2)
    Do While Datei <> ""
        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
    
    '* 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
    Application.DisplayAlerts = False
    TB.Delete
    Application.DisplayAlerts = True
    
End Sub

LG UweD
Anzeige
AW: Dateinamen anpassen
24.08.2017 10:34:45
Jens
Ja funkioniert auch ohne sortieren
Aber woher weis er dann die Zuordnung was zu was gehört.
Wie bekomme ich noch es hin, dass ich den Ordner in dem die Datein liegen auswählen kann.
Hätte es mit
pfad = Application.GetOpenFilename
versucht.
Aber hier muss ich ja dann eine Datei auswählen und ordner geht nicht.
AW: Dateinamen anpassen
24.08.2017 10:48:34
UweD
Hallo
Die verwendete Zuordnung kannst du "sehen", wenn du das Blatt am Ende nicht automatisch löschst

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
Dim Dlg As FileDialog
Set Dlg = Application.FileDialog(msoFileDialogFolderPicker) 'Verzeichnis wählen
If Dlg.Show = True Then
Pfad = Dlg.SelectedItems(1) & "\"
Ext1 = ".csv"
Ext2 = ".pdf"
Set TB = ActiveWorkbook.Sheets.Add
'* CSV Namen einlesen
Datei = Dir(Pfad & "*" & Ext1)
Do While Datei  ""
i = i + 1
TB.Cells(i, 1) = Datei
Datei = Dir
Loop
i = 0
'* PDF Namen einlesen
Datei = Dir(Pfad & "*" & Ext2)
Do While Datei  ""
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
'* 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
Application.DisplayAlerts = False
'****TB.Delete
Application.DisplayAlerts = True
End If
End Sub
LG UweD
Anzeige
AW: Dateinamen anpassen
24.08.2017 10:51:54
Jens
optimal.
Danke :)
Danke für die Rückmeldung owT
24.08.2017 10:56:27
UweD

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige