Data copy von USB auf HDD

Sub Copy_USB() ' Daten von USB Stick copieren Dim filesystem As Object Dim name As String Dim intResult As Integer Dim strPath As String intResult = Application.FileDialog(msoFileDialogFolderPicker).Show If intResult 0 Then Sheets("AUSWAHL").Range("L2") = (Application.FileDialog(msoFileDialogFolderPicker _ ).SelectedItems(1)) End If If Sheets("WORKPAGE").Range("C9").Value = "ja" Then UserForm1.Show name = Format(Now(), "YYMMDD_hhmm_") & Sheets("WORKPAGE").Range("C7").Value & "_USB" & " _ _____Marker" Else name = Format(Now(), "YYMMDD_hhmm_") & Sheets("WORKPAGE").Range("C7").Value & "_USB" End If Set filesystem = CreateObject("Scripting.FileSystemObject") filesystem.CopyFolder Sheets("AUSWAHL").Range("L2").Value, "D:\" & name Set filesystem = Nothing End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Christian,
wenn man das Root-Verzeichnis kopieren möchte, dann muss man
- das Zielverzeichnis erstellen
- die Dateien ins Zielverzeichnis kopieren
- die Unterordner ins Zielverzeichnis kopieren
Auf meinem System lief das bei vielen zu kopierenden Unterordnern und Dateien sehr langsam.
LG
Franz

Sub Copy_USB()
' Daten von USB Stick copieren
Dim filesystem As Object
Dim sName As String
Dim intResult As Integer
Dim strPath As String
Dim oFolders As Variant
Dim oItem As Variant
Dim sZiel As String, sSource As String
With Application.FileDialog(msoFileDialogFolderPicker)
intResult = .Show
If intResult  0 Then
Sheets("AUSWAHL").Range("L2") = .SelectedItems(1)
Else
Exit Sub
End If
End With
If Sheets("WORKPAGE").Range("C9").Value = "ja" Then
UserForm1.Show
sName = Format(Now(), "YYMMDD_hhmm_") & Sheets("WORKPAGE").Range("C7").Value _
& "_USB" & "_____Marker"
Else
sName = Format(Now(), "YYMMDD_hhmm_") & Sheets("WORKPAGE").Range("C7").Value & "_USB"
End If
Set filesystem = CreateObject("Scripting.FileSystemObject")
sZiel = "D:\" & sName
sSource = Sheets("AUSWAHL").Range("L2").Value
If Right(sSource, 2) = ":\" Then
'Root-Ordner soll kopiert werden
'Zielordner anlegen
filesystem.createfolder sZiel
'Dateien im Rootverzeichnis kopieren
For Each oItem In filesystem.getfolder(sSource).Files
filesystem.Copyfile oItem.Path, sZiel & "\"
Next
'Ordner im Rootverzeichnis kopieren
Set oFolders = filesystem.getfolder(sSource).subFolders
For Each oItem In oFolders
filesystem.CopyFolder oItem, sZiel & "\"
Next
Else
'Ordner soll kopiert werden
filesystem.CopyFolder sSource, sZiel
End If
Set oFolders = Nothing
Set filesystem = Nothing
MsgBox "Fertig", vbOkOnly, "Ordner kopieren"
End Sub

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Data copy von USB auf HDD

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread