You are here:---Rispondi a: [RISOLTO] Individuazione di file in sottocartelle e copia in una nuova cartella
Rispondi a: [RISOLTO] Individuazione di file in sottocartelle e copia in una nuova cartella2018-05-05T16:14:35+02:00

Home Forum Domande su Excel VBA e MACRO [RISOLTO] Individuazione di file in sottocartelle e copia in una nuova cartella Rispondi a: [RISOLTO] Individuazione di file in sottocartelle e copia in una nuova cartella

sidsid
Moderatore
    Post totali: 718

    Una possibile soluzione
    ATTENZIONE…nei riferimenti di vba devi attivare la libreria MICROSOFT SCRIPTING RUNTIME

    Sub COPIA_PDF()
    Dim ws1 As Worksheet
    Dim fso As Scripting.FileSystemObject
    Dim CartellaSorgente As Scripting.Folder, CartellaTarget As Scripting.Folder, Cartella As Scripting.Folder
    Dim File As Scripting.File
    Dim sFile1 As String, sFile2 As String
    Dim nUltimaRiga As Long, nRiga As Long
    Dim bEsiste As Boolean
    Dim sLista As String
    
    Set fso = New Scripting.FileSystemObject
    Set ws1 = Sheets("Foglio1") 'nome tuo foglio
    Set CartellaSorgente = fso.GetFolder("C:\ARCHIVIO")
    Set CartellaTarget = fso.GetFolder("C:\NEW")
    
    nUltimaRiga = IIf(ws1.Range("B2") = vbNullString, 1, ws1.Range("B" & Rows.Count).End(xlUp).Row)
    
    If nUltimaRiga > 1 Then
        For nRiga = 2 To nUltimaRiga
            sFile1 = Left(ws1.Range("B" & nRiga), 9)
            
            'ciclo le sottocartelle
            For Each Cartella In CartellaSorgente.SubFolders
                
                'ciclo i file nella sottocartella
                For Each File In Cartella.Files
                        sFile2 = Left(File.Name, 9)
                        
                        'confronto i nomi dei file
                        If StrComp(sFile1, sFile2, vbTextCompare) = 0 Then
                            bEsiste = True
                            
                            'copia file nella cartella target
                            File.Copy (CartellaTarget & "\" & File.Name)
                        End If
                 Next File
            Next Cartella
            
            If Not bEsiste Then
                'creo la lista dei file non presenti nelle sottocartelle
                sLista = sLista & sFile1 & vbLf
            End If
            bEsiste = False
        Next nRiga
    End If
    
    If Len(sLista) > 0 Then
        MsgBox sLista, vbInformation, "lista file non presenti"
    End If
    
    Set fso = Nothing
    Set ws1 = Nothing
    Set CartellaSorgente = Nothing
    Set CartellaTarget = Nothing
    
    End Sub

    Fa sapere, ciao.

    Utilizzando il sito, accetti l'utilizzo dei cookie da parte nostra. maggiori informazioni

    Questo sito utilizza i cookie per fornire la migliore esperienza di navigazione possibile. Continuando a utilizzare questo sito senza modificare le impostazioni dei cookie o cliccando su "Accetta" permetti il loro utilizzo.

    Chiudi