Zellen auslesen, in Ordnern suchen und kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Kopieren_() Dim rngRange As Range Dim sDir$ 'Bereich Set rngRange = Tabelle2.Range("A2:H9") 'Pfad Quelle Const sPathQuelle$ = "G:\1 Forum\" 'Pfad Ziel Const sPathZiel$ = "G:\1 Forum\Neuer Ordner (4)\" For Each rngRange In rngRange.Cells If rngRange.Value <> "" Then sDir = Dir$(sPathQuelle & rngRange.Value & "*.txt", vbNormal) If sDir <> "" Then FileCopy sPathQuelle & sDir, sPathZiel & sDir End If End If Next rngRange MsgBox "Fertig" End Sub

Hallo,
müsste so funktionieren!

Private Declare Function apiCreateFullPath _
Lib "imagehlp.dll" Alias "MakeSureDirectoryPathExists" (ByVal lpPath As String) As Long

Sub Kopieren_()
Dim rngRange As Range
Dim sDir$
Dim lngCreatePath&

'Bereich 
Set rngRange = Tabelle2.Range("A2:H9")
'Pfad Quelle 
Const sPathQuelle$ = "G:\1 Forum\"
'Pfad Ziel 
Const sPathZiel$ = "G:\1 Forum\Neuer Ordner (5)\"
'Ordner anlegen wenn nicht vorhanden 
lngCreatePath = apiCreateFullPath(Left$(sPathZiel, InStrRev(sPathZiel, "\")))

If lngCreatePath = 1 Then
    For Each rngRange In rngRange.Cells
        If rngRange.Value <> "" Then
            sDir = Dir$(sPathQuelle & rngRange.Value & "*.txt", vbNormal)
            If sDir <> "" Then
                FileCopy sPathQuelle & sDir, sPathZiel & sDir
            End If
        End If
    Next rngRange
    MsgBox "Fertig"
Else
    MsgBox "Ordner konnte nicht angelegt werden!", vbCritical
End If
End Sub

Gruß Tino

Hallo!
Mir ist eine neue Idee gekommen:
Für die Quelldatei wäre es sinnvoll das der Benutzer nicht den Ordner selbst suchen müsste in dem er die .txt Dateien finden kann sondern wenn das Makro es automatisch machen könnte. In der Excel Tabelle gibt es zwei Nummer: "123456" und "A12". Diese Nummern setzen sich zusammen zum Ordner "123456_A12". Jetzt wäre es klasse wenn das Makro den Quellpfad bekommt und in der Liste der vielen Ordner anhand der zwei Nummern den richtigne findet.
Dannach soll wie gehabt nach der Eingabe der Seriennnummern er die Zellen abgleichen und in dem Ordner nach der .txt Datei suchen, kopieren in einen Ordner mit dem Namen der in einer Zelle zu Beginn steht und diesen speichern und am Ende eine Msg Box aufpoppen.
Die Msg Box soll foglenden Inhalt haben: 15 von 15 kopiert oder noch besser wenn er sagen könnte welche Dateien nicht gefunden wurden, wenn es dazu kommt.
Vielen vielen Dank

Beliebteste Forumthreads (12 Monate)

Zellen auslesen, in Ordnern suchen und kopieren

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

315 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellen auslesen, in Ordnern suchen und kopieren

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

315 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread