Dateien Speichern nach Inhalt in Spalte

Hallo zusammen,

in meiner Tabelle1 stehen in Spalte A untereinander verschiedene Dateipfade aus einem Quellordner, diese sollen zu den daneben stehenden Ordnerpfaden in Spalte B kopiert werden.
Es kann vorkommen, dass dieselbe Datei (Quellordner) 2x oder öfter in den gleichen Zielordner kopiert werden muss, dann könnte eine fortlaufende Nummer oder "Kopie" anfügen werden.
Die Anzahl der zu kopierenden Dateien kann von 10-500 schwanken, eine Datei ist etwa 50KB groß, das sollte (denke ich) auch bei noch höheren Kopiervorgängen kein Problem sein.

Ich füge eine Beispieldatei hinzu, dort benötige ich z.b. die ersten drei gleichen Quelldateien im Ordner C:\Daten\10 > z.b. A020L.SVG, A020L_1.SVG und A020L_2.SVG

Kann/möchte mir hier jemand helfen? Bisher hatte ich nur Makros aufgezeichnet, komme jetzt leider schon an meine Grenzen.

Gruß Andreas

https://www.herber.de/bbs/user/158725.xlsx

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub CopyFiles() Dim destFolder As String 'Zielordner Dim fileName As String 'Dateiname Dim destFileName As String 'Zieldateiname (falls vorhanden) Dim i As Long 'Schleifenindex Dim copyIndex As Integer 'Index für Kopien 'Schleife durch alle Zeilen in der Tabelle For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row 'Starte bei Zeile 2, um die Überschrift zu überspringen 'Setze den Zielordner destFolder = Cells(i, 2).Value 'Extrahiere den Quellordner aus dem Dateipfad Dim fileParts() As String fileParts = Split(Cells(i, 1).Value, "\") Dim srcFolder As String srcFolder = Left(Cells(i, 1).Value, Len(Cells(i, 1).Value) - Len(fileParts(UBound(fileParts)))) 'Füge den Dateinamen zum Quellpfad hinzu fileName = Cells(i, 1).Value 'Prüfe, ob die Datei bereits im Zielordner vorhanden ist If Dir(destFolder & "\" & Cells(i, 1).Value) > "" Then 'Wenn ja, füge einen Index hinzu copyIndex = 1 Do While Dir(destFolder & "\" & Left(Cells(i, 1).Value, Len(Cells(i, 1).Value) - 4) & "_" & copyIndex & ".svg") > "" copyIndex = copyIndex + 1 Loop destFileName = Left(Cells(i, 1).Value, Len(Cells(i, 1).Value) - 4) & "_" & copyIndex & ".svg" Else destFileName = Cells(i, 1).Value End If 'Kopiere die Datei in den Zielordner FileCopy srcFolder & fileName, destFolder & "\" & destFileName Next i 'Fertig MsgBox "Kopieren abgeschlossen." End Sub

Ich weiß nicht genau was ich getan habe aber es funktioniert nun... habe die Variable fileParts(2) gegen etwas anderes ersetzt.

Danke für den Code bzw. den Denkanstoß.
Grüße

Sub CopyFiles()

    Dim destFolder As String 'Zielordner
    Dim fileName As String 'Dateiname
    Dim destFileName As String 'Zieldateiname (falls vorhanden)
    Dim i As Long 'Schleifenindex
    Dim copyIndex As Integer 'Index für Kopien
    
    'Schleife durch alle Zeilen in der Tabelle
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row 'Starte bei Zeile 2, um die Überschrift zu überspringen
       
        'Setze den Zielordner
        destFolder = Cells(i, 2).Value
        
        'Extrahiere den Quellordner aus dem Dateipfad
        Dim fileParts() As String
        fileParts = Split(Cells(i, 1).Value, "\")
        Dim srcFolder As String
        srcFolder = Left(Cells(i, 1).Value, Len(Cells(i, 1).Value) - Len(fileParts(UBound(fileParts))))
        
        'Füge den Dateinamen zum Quellpfad hinzu
        fileName = Cells(i, 1).Value
        
         'Ist Zielordner vorhanden?
        If Dir$(destFolder & "\", vbDirectory) = "" Then MkDir destFolder & "\"
        
        'Prüfe, ob die Datei bereits im Zielordner vorhanden ist
        If Dir(destFolder & "\" & fileParts(2)) > "" Then
            
            'Wenn ja, füge einen Index hinzu
            copyIndex = 1
            Do While Dir(destFolder & "\" & Left(fileParts(2), Len(fileParts(2)) - 4) & "_" & copyIndex & ".svg") > ""
                copyIndex = copyIndex + 1
            Loop
            destFileName = Left(fileParts(2), Len(fileParts(2)) - 4) & "_" & copyIndex & ".svg"
        Else
            destFileName = fileParts(2)
        End If
        
        'Kopiere die Datei in den Zielordner
    
        FileCopy srcFolder & fileParts(2), destFolder & "\" & destFileName
        
    Next i
    
    'Fertig
    MsgBox "Kopieren abgeschlossen."
    
End Sub

Beliebteste Forumthreads (12 Monate)

Dateien Speichern nach Inhalt in Spalte

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

227 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Dateien Speichern nach Inhalt in Spalte

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

227 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread