la copie de fichiers à partir de plusieurs sous-dossiers à l'aide de vba

J'ai vu un peu de documentation sur ce sujet, mais jusqu'à présent, rien de ce que j'ai été capable de reproduire pour mon projet spécifique.

Mes points de code dans un répertoire qui contient 60 ou si les sous-dossiers. Au sein de ces sous-dossiers sont plusieurs fichiers .PDF/.XLS etc. Le code suivant fonctionne très bien si les fichiers ne sont pas intégrées dans les sous-dossiers, mais ce dont j'ai besoin pour faire est d'être en mesure de boucle à travers les sous-dossiers et de récupérer les fichiers eux-mêmes pour se déplacer. Aussi, est-il un moyen pour éventuellement tirer de fichiers par nom générique? Merci d'avance pour toute aide.

  Dim FSO As Object
  Dim FromPath As String
  Dim ToPath As String
  Dim Fdate As Date
  Dim FileInFromFolder As Object

  FromPath = "H:\testfrom\"
  ToPath = "H:\testto\"

  Set FSO = CreateObject("scripting.filesystemobject")
  For Each FileInFromFolder In FSO.getfolder(FromPath).Files
  Fdate = Int(FileInFromFolder.DateLastModified)
      If Fdate >= Date - 1 Then

        FileInFromFolder.Copy ToPath

    End If
Next FileInFromFolder
End Sub

Avez-vous vérifié this?
- Je.. je ne suis pas sûr de la façon de les intégrer avec ce que j'ai déjà.

InformationsquelleAutor gfuller40 | 2014-10-01

Vous pouvez également utiliser la récursivité. Votre dossier peut avoir des sous-dossiers ayant des sous-dossiers ayant ...

Public Sub PerformCopy()
    CopyFiles "H:\testfrom\", "H:\testto\"
End Sub


Public Sub CopyFiles(ByVal strPath As String, ByVal strTarget As String)
    Set FSO = CreateObject("scripting.filesystemobject")
    'First loop through files
    For Each FileInFromFolder In FSO.getfolder(strPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        If Fdate >= Date - 1 Then
            FileInFromFolder.Copy strTarget
        End If
    Next FileInFromFolder 


    'Next loop throug folders
    For Each FolderInFromFolder In FSO.getfolder(strPath).SubFolders
        CopyFiles FolderInFromFolder.Path, strTarget
    Next FolderInFromFolder
End Sub

InformationsquelleAutor Barry

J'ai trouvé la solution ici:

 Private Sub Command3_Click()

Dim objFSO As Object 'FileSystemObject
Dim objFile As Object 'File
Dim objFolder As Object 'Folder
Const strFolder As String = "H:\testfrom2\"
Const strNewFolder As String = "H:\testto\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFolder In objFSO.GetFolder(strFolder & "\").SubFolders
    'If Right(objFolder.Name, 2) = "tb" Then
        For Each objFile In objFolder.Files
            'If InStr(1, objFile.Type, "Excel", vbTextCompare) Then
                On Error Resume Next
    Kill strNewFolder & "\" & objFile.Name
 Err.Clear: On Error GoTo 0

                Name objFile.Path As strNewFolder & "\" & objFile.Name
            'End If
        Next objFile
    'End If
Next objFolder


End Sub

InformationsquelleAutor gfuller40

J'ai réussi à obtenir ce code fonctionne. Il copie tous les dossiers /fichiers et sous-dossiers et leurs fichiers de la nouvelle destination (strTarget).

Je n'ai pas ajouté de contrôles et de contrepoids comme 1) si les fichiers et les dossiers existent déjà. 2) si les fichiers source sont ouverts etc. Si ces ajouts pourraient être utiles.

J'ai eu ce code de Barry post mais nécessaire de la modifier pour le faire fonctionner pour moi, donc j'ai pensé partager à nouveau de toute façon.

Espère que cela est utile. . .

strPath est le chemin d'accès source et strTarget est le chemin de destination. les deux chemins devraient se terminer par '\'

Remarque: on doit ajouter "Microsoft Scripting Runtime" sous "Outils /Références" de l'OFS pour le travail.

==================== call ================================
MkDir "DestinationPath"

CopyFiles "SourcePath" & "\", "DestinationPath" & "\"

==================== Copy sub ===========================

Public Sub CopyFiles(ByVal strPath As String, ByVal strTarget As String)
Dim FSO As Object
Dim FileInFromFolder As Object
Dim FolderInFromFolder As Object
Dim Fdate As Long
Dim intSubFolderStartPos As Long
Dim strFolderName As String

Set FSO = CreateObject("scripting.filesystemobject")
'First loop through files
    For Each FileInFromFolder In FSO.GetFolder(strPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'If Fdate >= Date - 1 Then
            FileInFromFolder.Copy strTarget
        'end if
    Next

    'Next loop throug folders
    For Each FolderInFromFolder In FSO.GetFolder(strPath).SubFolders
        'intSubFolderStartPos = InStr(1, FolderInFromFolder.Path, strPath)
        'If intSubFolderStartPos = 1 Then

        strFolderName = Right(FolderInFromFolder.Path, Len(FolderInFromFolder.Path) - Len(strPath))
        MkDir strTarget & "\" & strFolderName

        CopyFiles FolderInFromFolder.Path & "\", strTarget & "\" & strFolderName & "\"

    Next 'Folder

End Sub

InformationsquelleAutor Tristan

Vous devez vous connecter pour publier un commentaire.