Dateien kopieren

Bild

Betrifft: Dateien kopieren
von: Rene
Geschrieben am: 05.04.2005 12:50:26
Moin zusammen,
Ich muß leider schon wieder nerven. Habe diesen Code:
Option Explicit
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260


Function BrowseFolder(Optional Caption As String, _
   Optional InitialFolder As String) As String
   Dim Sh As shell32.Shell
   Dim F As shell32.Folder
   Set Sh = New shell32.Shell
   Set F = Sh.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, _
   InitialFolder)
   If Not F Is Nothing Then
      BrowseFolder = F.Items.Item.Path
   End If
End Function



Sub Xls_und_RCA_Dateien_kopieren()
'On Error Resume Next
Dim objFSO As Object
Dim fSearch As FileSearch
Dim srcPath As String, tarpath As String, srcFile As String, tarFile As String
Dim fCount As Integer
srcPath = BrowseFolder("Order wählen", "C:\Test\Test1\RCA\")   'Quellverzeichnis
tarpath = "C:\Test\"  'Zielverzeichnis
If srcPath = "" Then Exit Sub
Set fSearch = Application.FileSearch
With fSearch
'ermitteln der Anzahl von *.xls - Files im Quellverzeichnis
.NewSearch
.LookIn = srcPath
.SearchSubFolders = False  '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeAllFiles
.Filename = "*.xls"
.Execute
'ermitteln der Anzahl von *.mem - Files im Quellverzeichnis
.NewSearch
.LookIn = srcPath
.SearchSubFolders = False  '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeAllFiles
.Filename = "*.mem"
.Execute
Set objFSO = CreateObject("Scripting.FileSystemObject")
For fCount = 1 To .FoundFiles.Count
If Right(.FoundFiles(fCount), 3) = "mem" Then
      
      'mem-File kopieren und umbenennen
         srcFile = .FoundFiles(fCount)
         tarFile = tarpath & "\RCA" & ".mem"
         objFSO.CopyFile srcFile, tarFile
 ElseIf Right(.FoundFiles(fCount), 2) = "xls" Then
      
      'xls-File kopieren und umbenennen
         srcFile = .FoundFiles(fCount)
         tarFile = tarpath & "\Liste1" & ".xls"
         objFSO.CopyFile srcFile, tarFile
         
Workbooks.Open Filename:="C:\Test\Liste1.xls"
Application.ScreenUpdating = False
Range("A1:I87").Select
Selection.Copy
Windows("Liste.xls").Activate
Range("A1:I87").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Windows("Liste1.xls").Activate
ActiveWindow.Close SaveChanges:=False
Range("A1").Select
Application.ScreenUpdating = True
kill ("C:\Test\Liste1.xls")
      End If
   
   Next
End With
Set objFSO = Nothing
Set fSearch = Nothing
End Sub

Wenn ich ihn so ausführe kopiert er mir nur die RCA Datei und macht bei der xls Datei gar nichts. Wenn ich nun aber das Macro so schreibe das er nur die xls Datei kopieren soll geht es. Nur eben beide zusammen gehen nicht.Ich brauch aber beide Dateien. Kann mir dabei einer mal bitte helfen was hier falsch ist?
Danke im Vorraus
Rene
Bild

Betrifft: AW: Dateien kopieren
von: Harald Kapp
Geschrieben am: 05.04.2005 13:00:13
Hallo Rene,
ohne Deinen Code im Detail durchgearbeitet zu haben denke ich der Fehler liegt beim Suchen.
Mit diesem Codestück
'ermitteln der Anzahl von *.xls - Files im Quellverzeichnis
.NewSearch
.LookIn = srcPath
.SearchSubFolders = False '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeAllFiles
.Filename = "*.xls"
.Execute
'ermitteln der Anzahl von *.mem - Files im Quellverzeichnis
.NewSearch
.LookIn = srcPath
.SearchSubFolders = False '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeAllFiles
.Filename = "*.mem"
.Execute
scheinst Du zu versuchen, die Anzahl der mem und xls File sermitteln zu wollen. Wie aber ".NewSearch" sagt, verwirfst Du die Ergebnisse der ersten Suche (xls) und erhältst folgerichtig nur die mem files.
Ich denke, Du wirst nicht beide Filetypen in einer Schleife bearbeiten können. Das Konstrukt muss eher so aussehen:
.xls files suchen
.xls files kopieren
.mem files suchen
.mem files kopieren

Gruß Harald
Bild

Betrifft: AW: Dateien kopieren
von: Rene
Geschrieben am: 05.04.2005 13:09:26
Hallo Harald,
Danke dir für deine Antwort. Das merkwürdige an der Sache ist aber das ich diesen Code habe:

Sub DQM_und_PS_Dateien_verschieben()
Dim objFSO As Object
Dim fSearch As FileSearch
Dim srcPath As String, tarpath As String, srcFile As String, tarFile As String
Dim dqmCount As Integer, psCount As Integer, fCount As Integer
srcPath = "C:\DQM\Messung"  'Quellverzeichnis
tarpath = BrowseFolder("Order wählen", "C:\DQM\Messung")  'Zielverzeichnis
If tarpath = "" Then Exit Sub
Set fSearch = Application.FileSearch
With fSearch
'ermitteln der Anzahl von *.dqm - Files im Zielordner
.NewSearch
.LookIn = tarpath
.SearchSubFolders = False  '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeAllFiles
.Filename = "*.dqm"
.Execute
dqmCount = .FoundFiles.Count
'ermitteln der Anzahl von *.ps - Files im Zielordner
.NewSearch
.LookIn = tarpath
.SearchSubFolders = False  '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeAllFiles
.Filename = "*.ps"
.Execute
psCount = .FoundFiles.Count
'Auslesen des Quellordners
.NewSearch
.LookIn = srcPath
.SearchSubFolders = False  '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeAllFiles
.Execute
Set objFSO = CreateObject("Scripting.FileSystemObject")
   For fCount = 1 To .FoundFiles.Count
   
      If Right(.FoundFiles(fCount), 3) = "dqm" Then
      
         'dqm-File verschieben und umbenennen
         srcFile = .FoundFiles(fCount)
         
         tarFile = tarpath & "\Mp" & Format(dqmCount, "000") & ".dqm"
         
         objFSO.MoveFile srcFile, tarFile
         
         dqmCount = dqmCount + 1
      
      ElseIf Right(.FoundFiles(fCount), 2) = "ps" Then
      
         'ps-File verschieben und umbenennen
         srcFile = .FoundFiles(fCount)
         
         tarFile = tarpath & "\Mp" & Format(psCount, "000") & ".ps"
         
         objFSO.MoveFile srcFile, tarFile
         
         psCount = psCount + 1
      
      End If
   
   Next
End With
Set objFSO = Nothing
Set fSearch = Nothing
End Sub

Dieser geht mit den beiden Dateien prima.Nun hatte ich gehofft wenn ich diesen mir umschreibe das es dann auch gehen müßte,aber leider ist diese nicht der Fall.
Hast du eine Idee warum dieses so ist?
Gruß Rene
Bild

Betrifft: AW: Dateien kopieren
von: Harald Kapp
Geschrieben am: 05.04.2005 13:44:43
Hallo Rene,
jaaaaa...
Bei diesem Code merkst Du Dir ja auch die Anzahl der Dateien aus den ersten beiden Suchen in den Variablen dqmcount und pscount. Dann gehst Du noch einmal alle Files durch und verarbeitest nur die ps und dqm files.
Vorschlag zum (imho) besseren Verständnis des Codes:

Sub DQM_und_PS_Dateien_verschieben()
Dim objFSO As Object
Dim fSearch As FileSearch
Dim srcPath As String, tarpath As String, srcFile As String, tarFile As String
Dim dqmCount As Integer, psCount As Integer, fCount As Integer
srcPath = "C:\DQM\Messung"  'Quellverzeichnis
tarpath = BrowseFolder("Order wählen", "C:\temp\test")  'Zielverzeichnis
If tarpath = "" Then Exit Sub
Set fSearch = Application.FileSearch
Set objFSO = CreateObject("Scripting.FileSystemObject")
With fSearch
'ermitteln der Anzahl von *.dqm - Files im Zielordner
.NewSearch
.LookIn = tarpath
.SearchSubFolders = False  '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeAllFiles
.Filename = "*.dqm"
.Execute
dqmCount = .FoundFiles.Count
   For fCount = 1 To .FoundFiles.Count
         'dqm-File verschieben und umbenennen
         srcFile = .FoundFiles(fCount)
         tarFile = tarpath & "\Mp" & Format(fCount, "000") & ".dqm"
         objFSO.MoveFile srcFile, tarFile
   Next
'ermitteln der Anzahl von *.ps - Files im Zielordner
.NewSearch
.LookIn = tarpath
.SearchSubFolders = False  '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeAllFiles
.Filename = "*.ps"
.Execute
   For fCount = 1 To .FoundFiles.Count
         'ps-File verschieben und umbenennen
         srcFile = .FoundFiles(fCount)
         tarFile = tarpath & "\Mp" & Format(dqmCount + fCount, "000") & ".ps"
         objFSO.MoveFile srcFile, tarFile
   Next
End With
Set objFSO = Nothing
Set fSearch = Nothing
End Sub


Gruß Harald
Bild

Betrifft: AW: Dateien kopieren
von: Rene
Geschrieben am: 05.04.2005 14:45:15
Hallo Harald,
Sorry das ich mich jetzt erst melde,
Wenn ich nun deinen Vorschlag von vorhin nehmen würde komm ich aber auch nicht richtig klar damit muß ich den gleichen Code nach End With noch mal einfügen?
Gruß Rene
Bild

Betrifft: AW: Dateien kopieren
von: Harald Kapp
Geschrieben am: 05.04.2005 14:52:58
Hallo Rene,
entschuldige, wenn ich das nicht deutlich ausgedrückt habe. Natürlich genügt eine der beiden Maßnahmen.
Mein Code beinhaltet ja schon zwei FOR-Schleifen, je eine für dqm und eine für ps files. Ich finde meine Lösung eleganter (ja ja, Hochmut kommt vor dem Fall), weil jede Schleife direkt auf den Suchergebnissen der vorhergehenden Suche operiert. Damit entfällt das explizite Abfragen der Datei-Extension.
Gruß Harald
Bild

Betrifft: AW: Dateien kopieren
von: Rene
Geschrieben am: 05.04.2005 16:07:36
Hallo Harald,
Ich hoffe ich nerve nicht zu doll.Habe nun diesen Code erstellt:
Option Explicit
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260


Function BrowseFolder(Optional Caption As String, _
   Optional InitialFolder As String) As String
   Dim Sh As shell32.Shell
   Dim F As shell32.Folder
   Set Sh = New shell32.Shell
   Set F = Sh.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, _
   InitialFolder)
   If Not F Is Nothing Then
      BrowseFolder = F.Items.Item.Path
   End If
End Function


Sub RCA_und_Liste_kopieren()
Dim objFSO As Object
Dim fSearch As FileSearch
Dim srcPath As String, tarpath As String, srcFile As String, tarFile As String
Dim memCount As Integer, xlsCount As Integer, fCount As Integer
srcPath = BrowseFolder("Order wählen", "C:\Test\Test1")  'Quellverzeichnis
tarpath = "C:\Test\"  'Zielverzeichnis
If srcPath = "" Then Exit Sub
Set fSearch = Application.FileSearch
Set objFSO = CreateObject("Scripting.FileSystemObject")
With fSearch
'ermitteln der Anzahl von *.mem - Files im Zielordner
.NewSearch
.LookIn = tarpath
.SearchSubFolders = False  '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeAllFiles
.Filename = "*.mem"
.Execute
memCount = .FoundFiles.Count
   For fCount = 1 To .FoundFiles.Count
         'mem-File verschieben und umbenennen
         srcFile = .FoundFiles(fCount)
         tarFile = tarpath & "\RCA" & ".mem"
         objFSO.CopyFile srcFile, tarFile
   Next
'ermitteln der Anzahl von *.xls - Files im Zielordner
.NewSearch
.LookIn = tarpath
.SearchSubFolders = False  '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeAllFiles
.Filename = "*.xls"
.Execute
   For fCount = 1 To .FoundFiles.Count
         'xls-File verschieben und umbenennen
         srcFile = .FoundFiles(fCount)
         tarFile = tarpath & "\Liste1" & ".xls"
         objFSO.CopyFile srcFile, tarFile
         
Workbooks.Open Filename:="C:\DQM\Liste1.xls"
Application.ScreenUpdating = False
Range("A1:I87").Select
Selection.Copy
Windows("Liste.xls").Activate
Range("A1:I87").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Windows("Liste1.xls").Activate
ActiveWindow.Close SaveChanges:=False
Range("A1").Select
Application.ScreenUpdating = True
kill ("C:\DQM\Liste1.xls")
         
   Next
End With
Set objFSO = Nothing
Set fSearch = Nothing
End Sub

Die "xls" Dateien macht er mir auch aber bei den "mem" Dateien scheitert es.Er kopiert mir nicht die Datei in den Ordner.Wenn die "RCA.mem" Datei vorhanden ist sagt er mir Zugriff verweigert. Es greift aber keiner auf die Datei zu.
Ich dreh hier noch durch,hast du eine Ahnung woran die liegen könnte?
Gruß Rene
Bild

Betrifft: Hurra so hab ich's gelöst!!!
von: Rene
Geschrieben am: 05.04.2005 17:36:16
Hallo Harald,
Wollte dir nur sagen das ich es nun endlich so gelöst habe:

Sub RCA_und_Liste_Datei_kopieren()
On Error Resume Next
Dim objFSO As Object
Dim fSearch As FileSearch
Dim srcPath As String, tarpath As String, srcFile As String, tarFile As String
Dim fCount As Integer, xlsCount As Integer
srcPath = BrowseFolder("Order wählen", "C:\Test\Test1\Test2\")   'Quellverzeichnis
tarpath = "C:\Test\"  'Zielverzeichnis
If srcPath = "" Then Exit Sub
Set fSearch = Application.FileSearch
Set objFSO = CreateObject("Scripting.FileSystemObject")
With fSearch
'ermitteln der Anzahl von *.mem - Files im Quellverzeichnis
.NewSearch
.LookIn = srcPath
.SearchSubFolders = False  '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeAllFiles
.Filename = "*.mem"
.Execute
For fCount = 1 To .FoundFiles.Count
 If Right(.FoundFiles(fCount), 3) = "mem" Then
      
      'xls-File kopieren und umbenennen
         srcFile = .FoundFiles(fCount)
         tarFile = tarpath & "\RCA" & ".mem"
         objFSO.CopyFile srcFile, tarFile
     End If
     
 'ermitteln der Anzahl von *.xls - Files im Zielordner
.NewSearch
.LookIn = srcPath
.SearchSubFolders = False  '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeAllFiles
.Filename = "*.xls"
.Execute
  If Right(.FoundFiles(fCount), 3) = "xls" Then
         'xls-File verschieben und umbenennen
         srcFile = .FoundFiles(fCount)
         tarFile = tarpath & "\Liste1" & ".xls"
         objFSO.CopyFile srcFile, tarFile
         
Workbooks.Open Filename:="C:\Test\Liste1.xls"
Application.ScreenUpdating = False
Range("A1:I87").Select
Selection.Copy
Windows("Liste.xls").Activate
Range("A1:I87").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Windows("Liste1.xls").Activate
ActiveWindow.Close SaveChanges:=False
Range("A1").Select
Application.ScreenUpdating = True
kill ("C:\Test\Liste1.xls")
             
    End If
     
     
    Next
End With
Set objFSO = Nothing
Set fSearch = Nothing
End Sub


Danke dir trotzdem noch mal für deine Hilfe.
Gruß Rene
 Bild

Beiträge aus den Excel-Beispielen zum Thema "Dateien kopieren"