Dateein verschieben / Code kürzen

Hallo Leute,
zunächst ein frohes neues Jahr wünsche ich euch allen....
Ich habe zwei Fragen zu meinem Code, mit den ich viele Dateien in einem Verzeichnis verschieben möchte. Vorher werden die Quellverzeichnisse angelegt, sofern diese nicht vorhanden sind..
1. kann man bitte den Code abkürzen?
2. wenn nichts zu verschieben gibt, sollte der Code weiter laufen. Zur Zeit bekomme stoppt der Code hier objFSO.MoveFile..., wenn es nicht zum Verschieben gibt.

Sub Dateien_verschieben()
Dim strQuelle_1 As String, strQuelle_2 As String, strQuelle_3 As String, strQuelle_4 As String
Dim strZiel_1 As String, strZiel_2 As String, strZiel_3 As String, strZiel_4 As String
Dim objFSO As Object
strQuelle_1 = "D:\DATEN\2017\Projekte\Berlin\*.csv"
strZiel_1 = "D:\DATEN\2017\Projekte\Berlin\CSV\"
strQuelle_2 = "D:\DATEN\2017\Projekte\Berlin\*.pdf"
strZiel_2 = "D:\DATEN\2017\Projekte\Berlin\PDF\"
strQuelle_3 = "D:\DATEN\2017\Projekte\Berlin\*.pcf"
strZiel_3 = "D:\DATEN\2017\Projekte\Berlin\PCF\"
strQuelle_4 = "D:\DATEN\2017\Projekte\Berlin\*.txt"
strZiel_4 = "D:\DATEN\2017\Projekte\Berlin\TXT\"
'Verzeichnis erstellen
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(strZiel_1) Then
fso.CreateFolder strZiel_1
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.MoveFile strQuelle_1, strZiel_1
Set objFSO = Nothing
'Verzeichnis erstellen
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(strZiel_2) Then
fso.CreateFolder strZiel_2
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.MoveFile strQuelle_2, strZiel_2
Set objFSO = Nothing
'Verzeichnis erstellen
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(strZiel_3) Then
fso.CreateFolder strZiel_3
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.MoveFile strQuelle_3, strZiel_3
Set objFSO = Nothing
'Verzeichnis erstellen
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(strZiel_4) Then
fso.CreateFolder strZiel_4
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.MoveFile strQuelle_4, strZiel_4
Set objFSO = Nothing
End Sub

Beste Grüße,
Sergej

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Dateien_verschieben() Dim strQuelle Dim strZiel Dim LoI As Long Dim Fso As Object Dim objFSO As Object 'arr = Array("ä", "ae", "ö", "oe", "ü", "ue", "ß", "ss") strZiel = Array("D:\DATEN\2017\Projekte\Berlin\CSV\", _ "D:\DATEN\2017\Projekte\Berlin\PDF\", "D:\DATEN\2017\Projekte\Berlin\PCF\", _ "D:\DATEN\2017\Projekte\Berlin\TXT\") strQuelle = Array("D:\DATEN\2017\Projekte\Berlin\*.csv", _ "D:\DATEN\2017\Projekte\Berlin\*.pdf", "D:\DATEN\2017\Projekte\Berlin\*.pcf", _ "D:\DATEN\2017\Projekte\Berlin\*.txt") Set Fso = CreateObject("Scripting.FileSystemObject") Set objFSO = CreateObject("Scripting.FileSystemObject") For LoI = 0 To UBound(strZiel) If Not Fso.FolderExists(strZiel(LoI)) Then Fso.CreateFolder strZiel(LoI) End If If Not objFSO.FolderExists(strQuelle(LoI)) Then objFSO.MoveFile strQuelle(LoI), strZiel(LoI) End If Next LoI Set objFSO = Nothing Set Fso = Nothing End Sub

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub Dateien_verschieben() Dim strSourcePath As String, strTargetPath As String, strTemp As String, varFiles As Variant Dim lngIndex As Long Dim objFSO As Object, objFolder As Object, objFile As Object strSourcePath = "D:\DATEN\2017\Projekte\Berlin\" strTargetPath = "D:\DATEN\2017\Projekte\Berlin\" varFiles = Array("*.csv", "*.pdf", "*.pcf", "*.txt") If Right(strSourcePath, 1) <> "\" Then strSourcePath = strSourcePath & "\" If Right(strTargetPath, 1) <> "\" Then strTargetPath = strTargetPath & "\" Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder(strSourcePath) For lngIndex = 0 To UBound(varFiles) strTemp = strTargetPath & UCase(Replace(varFiles(lngIndex), "*.", "")) & "\" If Not objFSO.FolderExists(strTemp) Then objFSO.CreateFolder strTemp End If For Each objFile In objFolder.Files If objFile.Name Like varFiles(lngIndex) Then objFSO.Movefile objFile, strTemp End If Next Next Set objFSO = Nothing End Sub

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub Dateien_verschieben() Dim strSourcePath As String, strTargetPath As String, strTemp As String, varFiles As Variant Dim lngIndex As Long Dim objFSO As Object, objFolder As Object, objFile As Object strSourcePath = "D:\DATEN\2017\Projekte\Berlin\" strTargetPath = "D:\DATEN\2017\Projekte\Berlin\" varFiles = Array("*.csv", "*.pdf", "*.pcf", "*.txt") If Right(strSourcePath, 1) <> "\" Then strSourcePath = strSourcePath & "\" If Right(strTargetPath, 1) <> "\" Then strTargetPath = strTargetPath & "\" Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder(strSourcePath) For lngIndex = 0 To UBound(varFiles) strTemp = strTargetPath & UCase(Replace(varFiles(lngIndex), "*.", "")) & "\" If Not objFSO.FolderExists(strTemp) Then objFSO.CreateFolder strTemp End If For Each objFile In objFolder.Files If LCase(objFile.Name) Like LCase(varFiles(lngIndex)) Then objFSO.Movefile objFile, strTemp End If Next Next Set objFile = Nothing Set objFolder = Nothing Set objFSO = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Dateein verschieben / Code kürzen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread