Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1580to1584
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
Alte Pdf in einen anderen Ordner verschieben
26.09.2017 07:30:53
Philipp
Hallo,
ich habe mehrere Ordner mit PDF's die eine bestimmte Namenskonvention einhalten.
Z.B: M_123456_00.pdf
M = Kürzel
Zahlen = Bezeichnung
00 = Index
Ich habe aber auch PDF's mit gleicher Bezeichnung und dem Index 01,02, 03 usw. Und ich möchte gerne das dier alten PDF's aus den Ordner verschoben werden in einen anderen (z.B. Archiv Ordner).
Ich habe es mir so gedacht:
PDF'S mit gleicher Bezeichnung nach Index vergleichen
PDF mit kleineren Index verschieben und PDF mit höherem Index im Ordner lassen.
Ansonsten wenn eine PDF mit der Bezeichnung nur einmalig vorhanden ist, dann soll sie im Ordner bleiben.
Ich habe dazu das hier, was bei der oben genannten Namenskonvetion jedoch nicht funktioniert:
Private Const Dateipfad_pdf_dateien As String = "C:..."
Private Const Dateipfad_archiv As String = "C:...Archiv"
Sub Pdf_archivieren()
Dim Dateiname As String, i As Integer
Dim Liste As Variant, x As Long
Dim Liste_archiv As Variant, y As Long
Dim NV As String, Weiter As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
ReDim Liste(x)
ReDim Liste_archiv(y)
Dateiname = Dir$(Dateipfad_pdf_dateien & "*.pdf")
Do While Dateiname ""
Weiter = True
ReDim Preserve Liste(x)
Liste(x) = Dateiname
x = x + 1
Dateiname = Dir$()
Loop
If Weiter = False Then Exit Sub
Weiter = False
For i = LBound(Liste) To UBound(Liste)
NV = Neueste_version(Liste(i))
If Liste(i) NV Then
Weiter = True
ReDim Preserve Liste_archiv(y)
Liste_archiv(y) = Liste(i)
y = y + 1
End If
Next i
If Weiter = False Then Exit Sub
For i = LBound(Liste_archiv) To UBound(Liste_archiv)
fso.MoveFile Dateipfad_pdf_dateien & Liste_archiv(i), _
Dateipfad_archiv & Liste_archiv(i)
Next i
End Sub

Public Function Neueste_version(Dateiname_vorgabe) As String
Dim c1 As Variant, c2 As Variant, Dateiname As String, DN As String, Dateiname_mem As _
String, Dateiname_alternativ As String, Nr_mem As Long, Nr2 As Long, Strg As String
DN = Left(Dateiname_vorgabe, (InStrRev(Dateiname_vorgabe, ".") - 1))
c1 = Split(DN, "_")
If UBound(c1) = 0 Then
Strg = Trim(DN)
Else
Strg = Trim(c1(0))
End If
Dateiname = Dir$(Dateipfad_pdf_dateien & "*.pdf")
Do While Dateiname ""
Dateiname_mem = Left(Dateiname, (InStrRev(Dateiname, ".") - 1))
c2 = Split(Dateiname_mem, "_")
If UBound(c2) = 0 Then
If LCase(Trim(c2(0))) = LCase(Strg) Then Dateiname_alternativ = Dateiname
GoTo Weiter
End If
Nr2 = CDbl(c2(1))
If LCase(Strg) = LCase(Trim(c2(0))) Then
If Nr2 > Nr_mem Then
Nr_mem = Nr2
Neueste_version = Dateiname
End If
End If
Weiter:
Dateiname = Dir$()
Loop
If Trim(Neueste_version) = "" Then Neueste_version = Dateiname_alternativ
End Function

Kann mir jemand weiter helfen bitte?
Liebe Grüße
Philipp

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Teste mal
26.09.2017 11:15:38
Michael
Hallo Philipp,
...diesen Code:
Sub a()
Dim DicDateien As Object
Dim HauptPfad$, ArchivPfad$
Dim Datei$, Bez$, Idx$
HauptPfad = "U:\Test" 'anpassen
ArchivPfad = "U:\Test\Archiv" 'anpassen
HauptPfad = IIf(Right(HauptPfad, 1) = "\", HauptPfad, HauptPfad & "\")
ArchivPfad = IIf(Right(ArchivPfad, 1) = "\", ArchivPfad, ArchivPfad & "\")
Set DicDateien = CreateObject("Scripting.Dictionary")
Datei = Dir(HauptPfad & "*.pdf", vbDirectory)
Do Until Datei = ""
Bez = Mid(Datei, 1, InStrRev(Datei, "_") - 1)
Idx = Mid(Datei, InStrRev(Datei, "_") + 1, 2)
If Not DicDateien.Exists(Bez) Then
DicDateien.Add Bez, Idx
Else:
If DicDateien(Bez) > Idx Then
Name HauptPfad & Datei As ArchivPfad & Datei
Else:
Name HauptPfad & Bez & "_" & DicDateien(Bez) & ".pdf" As _
ArchivPfad & Bez & "_" & DicDateien(Bez) & ".pdf"
DicDateien(Bez) = Idx
End If
End If
Datei = Dir
Loop
Set DicDateien = Nothing
End Sub
Bitte beachte, dass Du im Code noch die Pfade anpassen musst.
LG
Michael
Anzeige
AW: Teste mal
27.09.2017 09:22:32
Philipp
Hallo,
vielen Dank für deine Antwort und deine tolle Hilfe!
Das makro läuft einwandfrei :)
Kannst du mir noch eine Messagebox machen, die mir ausgibt wie viele Pdf's verschoben wurden?
Oder aber auch welche genau es waren?
Das wäre cool!
Liebe Grüße
Philipp
Ergänzt
27.09.2017 10:31:31
Michael
Hallo Philipp!
Freut mich, wenn's wie gewünscht läuft, teste folgende Ergänzung (Pfade wieder anpassen):
Sub a()
Dim DicDateien As Object
Dim HauptPfad$, ArchivPfad$
Dim Datei$, Bez$, Idx$, i&, Sammler$
HauptPfad = "U:\Test" 'anpassen
ArchivPfad = "U:\Test\Archiv" 'anpassen
HauptPfad = IIf(Right(HauptPfad, 1) = "\", HauptPfad, HauptPfad & "\")
ArchivPfad = IIf(Right(ArchivPfad, 1) = "\", ArchivPfad, ArchivPfad & "\")
Set DicDateien = CreateObject("Scripting.Dictionary")
Datei = Dir(HauptPfad & "*.pdf", vbDirectory)
Do Until Datei = ""
i = i + 1
Bez = Mid(Datei, 1, InStrRev(Datei, "_") - 1)
Idx = Mid(Datei, InStrRev(Datei, "_") + 1, 2)
If Not DicDateien.Exists(Bez) Then
DicDateien.Add Bez, Idx
Else:
If DicDateien(Bez) > Idx Then
Name HauptPfad & Datei As ArchivPfad & Datei
Sammler = Sammler & Datei & vbLf
Else:
Name HauptPfad & Bez & "_" & DicDateien(Bez) & ".pdf" As _
ArchivPfad & Bez & "_" & DicDateien(Bez) & ".pdf"
Sammler = Sammler & Bez & "_" & DicDateien(Bez) & ".pdf" & vbLf
DicDateien(Bez) = Idx
End If
End If
Datei = Dir
Loop
MsgBox "Es wurde(n) folgende " & i & " Datei(en) verschoben:" & vbLf & _
vbLf & Sammler, vbInformation, "Vorgang beendet"
Set DicDateien = Nothing
End Sub
LG
Michael
Anzeige
Keine Antwort mehr Philipp? Das ist schade, owT
28.09.2017 12:35:21
Michael
AW: Keine Antwort mehr Philipp? Das ist schade, owT
28.09.2017 15:18:41
Philipp
Hallo Michael,
entschuldigung das ich mich jetzt erst melde :(
Ich habe vorhin die Zeit gefunden es zu testen und es läuft super, Michael!
Außer wenn die Artikel eine andere Namenskonvetion hat, dann meckert er.
Wo müsste ich ein On error resume next setzen?
Ansonsten vielleicht noch eines:
Manche dateien haben hinter der revision ein "_DE" oder "EN" oder "DEEN" stehen.
Würde er es trotzdem berücksichtigen`?
AW: Keine Antwort mehr Philipp? Das ist schade, owT
28.09.2017 17:14:44
Michael
Philipp,
schön zwar, dass Du Dich noch meldest (hab ich beinahe übersehen), aber wenig erfreut bin ich über die nachträgliche Änderung der Anforderungen.
Außer wenn die Artikel eine andere Namenskonvetion hat, dann meckert er.
Ja klar, ist ja ein spezifischer Code für Deine Anforderungen, der wird nicht plötzlich universell, und...
Manche dateien haben hinter der revision ein "_DE" oder "EN" oder "DEEN" stehen.
Auch das ist eine Konventionsänderung.
Würde er es trotzdem berücksichtigen`?
Nein, natürlich nicht.
Ich bin also "not amused", aber da ich Dir schon den ersten Code geschrieben habe, hier eine schnelle Erweiterung:
Sub a()
Dim DicDateien As Object
Dim HauptPfad$, ArchivPfad$
Dim Datei$, Bez$, Idx$, i&, Sammler$, f$
HauptPfad = "U:\Test" 'anpassen
ArchivPfad = "U:\Test\Archiv" 'anpassen
HauptPfad = IIf(Right(HauptPfad, 1) = "\", HauptPfad, HauptPfad & "\")
ArchivPfad = IIf(Right(ArchivPfad, 1) = "\", ArchivPfad, ArchivPfad & "\")
Set DicDateien = CreateObject("Scripting.Dictionary")
Datei = Dir(HauptPfad & "*.pdf", vbDirectory)
Do Until Datei = ""
If Datei Like "?_######_##*.pdf" Then
Select Case UBound(Split(Datei, "_"))
Case 2
Bez = Mid(Datei, 1, InStrRev(Datei, "_") - 1)
Idx = Mid(Datei, InStrRev(Datei, "_") + 1, 2)
If Not DicDateien.Exists(Bez) Then
DicDateien.Add Bez, Idx
Else:
If DicDateien(Bez) > Idx Then
Name HauptPfad & Datei As ArchivPfad & Datei
Sammler = Sammler & Datei & vbLf: i = i + 1
Else:
Name HauptPfad & Bez & "_" & DicDateien(Bez) & _
".pdf" As ArchivPfad & Bez & "_" & _
DicDateien(Bez) & ".pdf"
Sammler = Sammler & Bez & "_" & _
DicDateien(Bez) & ".pdf" & vbLf
DicDateien(Bez) = Idx: i = i + 1
End If
End If
Case 3
Bez = Mid(Datei, 1, InStrRev(Datei, "_") - 4)
Idx = Mid(Datei, InStrRev(Datei, "_") - 2, 2)
f = Mid(Datei, InStrRev(Datei, "_") + 1, _
(InStrRev(Datei, ".")) - (InStrRev(Datei, "_") + 1))
If Not DicDateien.Exists(Bez) Then
DicDateien.Add Bez, Idx
Else:
If DicDateien(Bez) > Idx Then
Name HauptPfad & Datei As ArchivPfad & Datei
Sammler = Sammler & Datei & vbLf: i = i + 1
Else:
Name HauptPfad & Bez & "_" & DicDateien(Bez) & _
"_" & f & ".pdf" As ArchivPfad & Bez & "_" & _
DicDateien(Bez) & "_" & f & ".pdf"
Sammler = Sammler & Bez & "_" & DicDateien(Bez) & _
"_" & f & ".pdf" & vbLf
DicDateien(Bez) = Idx: i = i + 1
End If
End If
End Select
End If
Datei = Dir
Loop
MsgBox "Es wurde(n) folgende " & i & " Datei(en) verschoben:" & vbLf & _
vbLf & Sammler, vbInformation, "Vorgang beendet"
Set DicDateien = Nothing
End Sub
Damit werden jetzt alle Dateien im Verzeichnis übersprungen, die nicht dem Schema "?_######_##*.pdf" entsprechen, außerdem werden nun auch die Dateien mit "DE" etc. Zusatz verschoben. Achtung: Ich berücksichtige die Zusätze "_DE", "_EN" oder auch "_DEEN" nur, wenn das innerhalb der Dateibezeichnung nicht wechselt, also bei
P_457812_04_DE.pdf
P_457812_05_DE.pdf
P_457812_06_DE.pdf
werden die ersten beiden verschoben, die dritte bleibt.
Mit einem Suffix-Wechsel innerhalb einer Datei-Bezeichnung kann der Code aktuell nicht umgehen, das wäre komplexer, also
P_457812_04_DE.pdf
P_457812_05_EN.pdf
P_457812_06_DE.pdf
läuft in einen Fehler.
LG
Michael
Anzeige
AW: Keine Antwort mehr Philipp? Das ist schade, owT
29.09.2017 08:11:50
Philipp
Hallo Michael,
nochmals vielen Dank!
Ich habe es vorhin getestet und es läuft nun wirklich rund!
Schade das man hier keine pm's schicken kann, sonst hätte ich dir auch da nochmal danke geschrieben!
Liebe Grüße
Philipp
Freut mich, Danke für die Rückmeldung, owT
29.09.2017 10:36:21
Michael

301 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige