Dateien in vorgegebene Ordner kopieren

Hallo ihr Lieben,
ich hoffe sehr, dass ihr mir weiterhelfen könnt.
(Beispiel-Datei unten)
Ich bin Turnierfotograf, wo sehr viele Bilder entstehen, welche ich den einzelnen Teilnehmern zuordne.
Teilnehmer 1: Bild 1 - Bild 7
Teilnehmer 2: Bild 8 - Bild 21
usw.
Die Bilder werden am Abend zunächst ALLE unsortiert in einen bestimmten Ordner exportiert.
Hieraus sollen sie nun in einzelne Ordner, welche nach den Teilnehmern benannt sind, kopiert werden. (wichtig: kopiert)
Es besteht die Möglichkeit, dass von der selben Person mehrfach Bilder gemacht werden.
Zudem besteht die Möglichkeit, dass den gleichen Personen die selben Bilder zugeordnet werden müssen (z.B. bei Siegerehrungen).
Mit meinen mageren VBA-Kopier-Kenntnissen habe ich bereits überprüfen lassen, ob der Ordner mit dem Turniernamen und die Ordner mit den Teilnehmer-Namen bereits existieren. Wenn nicht, werden sie erstellt.
Weiter komme ich jedoch nicht, wie nun die Fotos den richtigen Teilnehmer-Ordnern zugeordnet werden sollen.
Ich habe mir mit Formeln rechts neben den Namen, die einzelnen Dateinamen ausgeben lassen. Evtl. hilft das ja weiter.
Schöner wäre es natürlich, wenn dies auch schon in VBA gelöst würde, da hier auch mal 150 Fotos entstehen können.
Auch eine Überprüfung, ob die Fotos bereits zugeordnet wurden, wäre cool. (Falls ich während dem Turniertag schon etwas exportiert hätte)
Die Fotos könnten dann einfach nochmals kopiert und überschrieben werden.
https://www.herber.de/bbs/user/148584.xlsm
Ich hoffe, ich konnte das Problem verständlich erklären.
Dank euch 1000fach vorab.
Grüße und einen schönen Mittwoch.
Alex

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub BilderCopy() Dim lngI As Long Dim strTurniername As String Dim strpathturniername As String Dim FS, strBildname As String, strExt As String, strExpOrd As String Dim strTeiln As String, intBild As Integer Dim strNeuBild As String 'Turniername wird aus B2 gezogen strTurniername = Range("B2").Value strpathturniername = "C:\Users\alexs\Pictures\" & strTurniername & "\" strBildname = Range("B4").Value strExt = Range("B6").Value strExpOrd = Range("B5").Value & "\" Set FS = CreateObject("Scripting.fileSystemObject") 'Abgleich, ob Ordner mit Turniernamen schon vorhanden ist If Dir$(strpathturniername, vbDirectory) = "" Then MkDir strpathturniername For lngI = 9 To Cells(Rows.Count, 1).End(xlUp).Row strTeiln = strpathturniername & Cells(lngI, 1) 'Abgleich, ob in dem o.a. Ordner bereits Ordner mit den Namen ab A9 vorhanden sind If Dir$(strTeiln, vbDirectory) = "" Then MkDir strTeiln For intBild = Cells(lngI, 2) To Cells(lngI, 3) strNeuBild = strBildname & intBild & "." & strExt FS.CopyFile strExpOrd & strNeuBild, strTeiln & "\" & strNeuBild, True 'Überschreiben: True oder False Next Next lngI End Sub

Code: [Cc][+][-] Option Explicit Private Declare PtrSafe Function CreateDirectory Lib "shell32" _ Alias "SHCreateDirectoryExW" ( _ ByVal hwnd As LongPtr, ByVal pszPath As LongPtr, _ ByVal psa As LongPtr) As Long Sub Fotos_Kopieren() Dim iZeile As Long, iNr As Integer Dim sMainPfad As String, sZielPfad As String, sQuellPfad As String Dim sDateiname As String, oFSO As Object Set oFSO = CreateObject("Scripting.FileSystemObject") With ThisWorkbook.Sheets("Bildzuordnung") ' Turniername wird aus B2 gezogen sMainPfad = "C:\Users\alexs\Pictures\" & .Range("B2").Value & "\" sQuellPfad = .Range("B5").Value & "\" For iZeile = 9 To .Cells(.Rows.Count, 1).End(xlUp).Row ' Zielpfad festsetzen und ggf. erstellen sZielPfad = sMainPfad & .Cells(iZeile, "A").Text If Dir$(sZielPfad, vbDirectory) = "" Then CreateDirectory 0&, StrPtr(sZielPfad), 0& ' Bilder kopieren For iNr = Val(.Cells(iZeile, "B").Value) To Val(.Cells(iZeile, "C").Value) sDateiname = .Range("B4").Value & iNr & "." & .Range("B6").Value If Dir$(sQuellPfad & sDateiname) <> "" Then oFSO.CopyFile sQuellPfad & sDateiname, sZielPfad & "\" & sDateiname End If Next iNr Next iZeile End With Set oFSO = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Dateien in vorgegebene Ordner kopieren

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Dateien in vorgegebene Ordner kopieren

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread