You are here:---Rispondi a: [RISOLTO] Ricerca in più sottocartelle
Rispondi a: [RISOLTO] Ricerca in più sottocartelle2018-05-10T17:51:12+02:00

Home Forum Domande su Excel VBA e MACRO [RISOLTO] Ricerca in più sottocartelle Rispondi a: [RISOLTO] Ricerca in più sottocartelle

sidsid
Moderatore
    Post totali: 718

    Ciao
    Queste 2 routine (macro + function) da inserire nello stesso modulo
    (attivare sempre la libreria MICROSOFT SCRIPTING RUNTIME)

    Sub COPIA_FILE()
    Dim ws1 As Worksheet
    Dim sPath1 As String, sPath2 As String, sLista As String, sFile1 As String
    Dim nUltimaRiga As Long, nRiga As Long
    Dim bEsiste As Boolean
    Set ws1 = Sheets("Foglio1") 'nome tuo foglio
    sPath1 = "C:\ARCHIVIO"
    sPath2 = "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)
            
            Call RICORSIVA(sPath1, sPath2, sFile1, sLista, bEsiste)
            
            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 ws1 = Nothing
    End Sub
    Function RICORSIVA(sPath1 As String, _
                    sPath2 As String, _
                    sFile1 As String, _
                    sLista As String, bEsiste As Boolean) As String
    
    Dim FSO As Scripting.FileSystemObject
    Dim myFolder As Scripting.Folder, MyFolderTarget As Scripting.Folder, mySubFolder As Scripting.Folder
    Dim myFile As Scripting.File
    Dim sFile2 As String
    
    Set FSO = New Scripting.FileSystemObject
    Set myFolder = FSO.GetFolder(sPath1)
    Set MyFolderTarget = FSO.GetFolder(sPath2)
    
    For Each mySubFolder In myFolder.SubFolders
            
        For Each myFile In mySubFolder.Files
                sFile2 = Left(myFile.Name, 9)
                
                'confronto i nomi dei file
                If StrComp(sFile1, sFile2, vbTextCompare) = 0 Then
                    bEsiste = True
                    myFile.Copy (sPath2 & "\" & myFile.Name)
                End If
        Next myFile
        RICORSIVA = RICORSIVA(mySubFolder.Path, sPath2, sFile1, sLista, bEsiste)
    Next mySubFolder
    
    Set FSO = Nothing
    Set myFolder = Nothing
    Set MyFolderTarget = Nothing
    
    End Function

    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