dir di sottocartelle

Hai un problema con Excel?

Nuova discussione

dir di sottocartelle
di tommy (utente non iscritto) data: 17/10/2016 22:34:08
Ciao a tutti,
sto cercando di risolvere un problema che mi sta facendo impazzire, ho queste due righe di codice:
"""percorso = "C:Users homasDesktopProgetti VBAproveprove" '<
MyFile = Dir(percorso & "*.txt")"""

ma ho la necessità di fare il dir anche delle sottocartelle del percorso "percorso" e non riesco a farlo potete aiutarmi?

riporto il codice completo:

grazie!

Sub importa_pass()

      Dim MyFile As String
      Dim percorso As String
      Dim FileTesto As String
      Dim ur As Long
    
      
      
      
      Sheets("report_pass").Select
      Rows("2:20000").Select
    Selection.ClearContents
      Selection.ClearContents

        percorso = "C:Users	homasDesktopProgetti VBAproveprove" '< ""
         FileTesto = percorso & "" & MyFile
         
         Call ImpFilesTesto(FileTesto)                                  'chiamo il codice che importa i file
         ur = Range("D" & Rows.count).End(xlUp).Row + 1                 ' trovo l' Ultima Riga della colonna D occupata e aggiungo 1
       
         Range("A4:A10").Copy                                              ' copio il primo report importato
         Range("D" & ur).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
         False, Transpose:=True                                             ' lo incollo trasposto nella prima riga libera sul foglio report
         Application.CutCopyMode = False
       
         
  
    
          Range("A1:A60").ClearContents                                    ' cancello il primo report importato dalla colonna A
         MyFile = Dir()
      Loop
End Sub

Sub ImpFilesTesto(FileTesto As String)
    Dim nRiga As Long, nvo As Integer, nv As Integer
    Dim nCol As Integer, Testo As String, Riga As String
    
    Sheets("report_pass").Select
    Open FileTesto For Input As #1
        nRiga = Range("A65000").End(xlUp).Row
        If nRiga = 1 Then
           nRiga = 0
        Else
           nRiga = nRiga + 1
        End If
leggiAncora:
        nRiga = nRiga + 1
        If Not EOF(1) Then
            Line Input #1, Riga
            nvo = 0: nCt = Len(Riga): nCol = 0
scanTesto:
            nCol = nCol + 1
            nv = InStr(nvo + 1, Riga, ",")
            If nv = 0 Then
              Testo = Right(Riga$, nCt - nvo)
              Cells(nRiga, nCol) = Testo$
              GoTo leggiAncora
            End If
            Testo = Mid(Riga$, nvo + 1, (nv - 1) - nvo)
            nvo = nv
            Cells(nRiga, nCol) = Testo
            GoTo scanTesto
        End If
    Close #1
End Sub

di patel data: 18/10/2016 09:14:09
questo è un codice di esempio per aprire tutti i file di una cartella e le sue sotto cartelle, adattalo al tuo caso

Sub OpenFilesSubFolder()
    Dim objFSO As Object, objTopFolder As Object, strTopFolderName As String
    strTopFolderName = "F:downloadesempio"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objTopFolder = objFSO.GetFolder(strTopFolderName)
    Call Recursive_Folder(objTopFolder, True)
    MsgBox ("fatto")
End Sub
Sub Recursive_Folder(objFolder As Object, IncludeSubFolders As Boolean)
    Dim objFile As Object
    Dim objSubFolder As Object
    Dim NextRow As Long
    NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
    For Each objFile In objFolder.Files
      Set exlWb = Workbooks.Open(objFolder.Path & "" & objFile.Name)
      MsgBox "aperto file " & objFile.Name
      exlWb.Close ' savechanges:=True
    Next objFile
    If IncludeSubFolders Then
        For Each objSubFolder In objFolder.SubFolders
            Call Recursive_Folder(objSubFolder, True)
        Next objSubFolder
    End If
    
End Sub

Vuoi Approfondire?