Scrive cartelle e sottocartelle

Hai un problema con Excel?

Nuova discussione

Scrive cartelle e sottocartelle
di Alessandro (utente non iscritto) data: 16/07/2013 17:34:01
Salve,
vorrei scrivere in un foglio di excel delle righe contenenti il titolo della prima cartella di un percorso,
quindi in colonna, in corrispondenza di ogni titolo, le sottocartelle contenute in ciascuna "prima cartella".

Esempio: nella cartella "D:car" ci sono le cartelle "x1" (che contiene "x1a" e "x1b"), "x2" (che contiene "x2a" e "x2b"), "x3" (che contiene "x3a"), e "x4" (che contiene "x4a" e "x4b").
io vorrei ottenere:
nella cella B2 la scritta "x1", in B3 "x1a" in B4 "x1b"
nella cella C2 la scritta "x2", in C3 "x2a" in C4 "x2b"
nella cella D2 la scritta "x3", in D3 "x3a"
nella cella E2 la scritta "x4", in E3 "x4a"

Spulciando nel sito ho trovato degli spunti interessanti che mi hanno permesso di creare il codice che allego, ma le scritte appaioni una sotto l'altra, tutte nella colonna B.
Come potrei fare per risolvere il problema?
Alessandro
P.S. volevo allegare delle immagini per chiarire il concetto, ma non so come fare

Option Explicit

Private oFileSys As Object, nFiles As Long, nSubDirs As Long, ext_file As String

Sub elenco_files_e_cartelle()
Dim source As String, i As Long, j As Long, v As Variant, ext As Variant, c As Collection

    source = "d:car"
    
    Set oFileSys = CreateObject("Scripting.FileSystemObject")
    
    [A:C].Clear
           
    GetDir1 source, i
        
    [c1].Select
    MsgBox "Completato"

End Sub

Private Function GetDir1(dir, i As Long) As Long
Dim oFolder As Object, oFolders As Object, oFiles As Object, oFold As Object, oFile As Object

    Set oFolder = oFileSys.GetFolder(dir)
    Set oFolders = oFolder.SubFolders
   
    On Error GoTo gest_err
    
   
    
    For Each oFold In oFolders
        i = i + 1
        If i > Rows.Count Then MsgBox "Limite del foglio raggiunto!": Exit Function
        Cells(i, 2) = oFold.Name
        Cells(i, 2).Font.Bold = 1
        GetDir1 oFold, i
       Next
    
    Exit Function
    
gest_err:
    If Err.Number = 70 Then Resume Next
    
End Function




Function duplicates(vettore As Variant) As Collection
Dim v As Variant, dups As Collection
    
    Set dups = New Collection
    
    On Error Resume Next
    
    For Each v In vettore
        dups.Add CStr(v), v
    Next
    
    On Error GoTo 0
    Set duplicates = dups

End Function

di Vecchio Frac data: 17/07/2013 15:30:27
Eccoti il codice corretto.
Questo codice elenca solo le cartelle, non anche i file. Se ti serve questa soluzione bisogna scrivere qualche altra riga.

Probabilmente hai trovato una mia vecchia soluzione ma va adattata :)
Ho eliminato la function duplicates che non ti serve in questo caso.
Anche molti oggetti inutili non serve dichiararli, se poi non li usi.

Option Explicit

Private oFileSys As Object

Sub elenco_files_e_cartelle()
Dim source As String, i As Long, j As Long, v As Variant, ext As Variant, c As Collection

    source = "C:Documents and Settings5314495DocumentiDocumenti NOPPart. 35 - Riunioni periodiche (già art. 11)"
    
    Set oFileSys = CreateObject("Scripting.FileSystemObject")
    
    [A:Z].Clear
           
    get_dir source, 1, 1
        
    [C1].Select
    MsgBox "Completato"

End Sub


Private Function get_dir(dir, ByVal level As Integer, start_row As Long) As Long
Dim oFolder As Object, oSubFolders As Object, oFold As Object
Dim i As Long

    Set oFolder = oFileSys.GetFolder(dir)
    Set oSubFolders = oFolder.SubFolders
    
    Cells(start_row, level) = oFolder.Name
    Cells(start_row, level).Font.Bold = True
   
    start_row = start_row + 1
    If start_row > Rows.Count Then MsgBox "Limite del foglio raggiunto!": Exit Function
    
    If oFolder.SubFolders.Count > 0 Then level = level + 1
    
    For Each oFold In oSubFolders
        get_dir oFold, level, start_row
    Next
    
    Exit Function
        
End Function

di Vecchio Frac data: 17/07/2013 15:31:29
ops che stupido... devi modificare la variabile source perchè punti alla cartella che ti serve... per fare il mio test ho lasciato una cartella di questo computer :P

completato
di Alessandro (utente non iscritto) data: 17/07/2013 17:14:14
Grazie V.F.
procedendo per tentativi ero riuscito a trovare una soluzione che sistemava le scritte come mi andava bene: allego il codice.
adesso provo il tuo codice, che offre sicuramente altri spunti su cui ragionare.
Alessandro

Option Explicit

Private oFileSys As Object

Sub elenco_files_e_cartelle()
Dim source As String, i As Long, C As Long, j As Long, R As Long, R1 As Long, v As Variant, ext As Variant  'c As Collection

    source = "D:CAR"
    Sheets("Foglio8").Select
    Set oFileSys = CreateObject("Scripting.FileSystemObject")
    [B4:ZZ1000].Clear
    '[A:Z].Clear
    C = 2 'C= COLONNA SOTTOCARTELLE
    R = 2 'R=COLONNA CARTELLE PRINCIPALE
    
          
    GetDir1 source, i, C, R, R1
    
    [a1].Select
    MsgBox "Ho terminato."

End Sub

' ********** GETDIR 1 *********
Private Function GetDir1(dir, i As Long, C As Long, R As Long, R1 As Long) As Long
Dim oFolder As Object, oFolders As Object, oFiles As Object, oFold As Object, oFile As Object

    Set oFolder = oFileSys.GetFolder(dir)
    Set oFolders = oFolder.SubFolders

    On Error GoTo gest_err
    
   
    
    For Each oFold In oFolders '''''oFold
                
    
        i = i + 1
        If i > Rows.Count Then MsgBox "Limite del foglio raggiunto!": Exit Function

    
       ' Cells(i, 2) = oFold.Name ')oFold.Path & " * " & oFold.Name ')
       ' Cells(i, 2).Font.Bold = 1                  ')
        'GetDir1 oFold, i, w
        Cells(4, R) = oFold.Name ' R=COLONNA CARTELLE PRINCIPALI
        R1 = 6 'R1= RIGA DELLE SOTTOCARTELLE
        GetDir2 oFold, i + 1, C, R1
        C = C + 1
        R = R + 1
        
    Next
    
     Exit Function
    
gest_err:
    If Err.Number = 70 Then Resume Next
    
End Function


' ********** GETDIR 2 *********

Private Function GetDir2(dir, i As Long, C As Long, R1 As Long) As Long
Dim oFolder As Object, oFolders As Object, oFiles As Object, oFold As Object, oFile As Object

    Set oFolder = oFileSys.GetFolder(dir)
    Set oFolders = oFolder.SubFolders
    
    On Error GoTo gest_err

    For Each oFold In oFolders '''''oFold
       
        i = i + 1
        
        
       
        If i > Rows.Count Then MsgBox "Limite del foglio raggiunto!": Exit Function

       
        Cells(R1, C) = oFold.Name ')oFold.Path & " * " & oFold.Name ')
        Cells(R1, C).Font.Bold = 1                  ')
        R1 = R1 + 1
        'GetDir2 oFold, i
    Next
   ' Next
    Exit Function
    
 ' ************* GEST ERRORI *********
gest_err:
    If Err.Number = 70 Then Resume Next
    
End Function

Vuoi Approfondire?