Excel VBA Compter le nombre de lignes dans tous les fichiers des dossiers et sous-dossiers

Question

J'essaie d'ajouter une boucle Do While pour obtenir le nombre de lignes de chaque fichier trouvé dans le dossier spécifié. Je n'y arrive pas - j'obtiens toujours 0 ligne avec toutes les versions de mon code. Vous trouverez ci-dessous le code original sans l'ajout du nombre de lignes. Je me heurte à un mur et j'aimerais avoir des conseils.

Sub ListAllFilesInAllFolders()

    Dim MyPath As String, MyFolderName As String, MyFileName As String
    Dim i As Integer, F As Boolean
    Dim objShell As Object, objFolder As Object, AllFolders As Object, AllFiles As Object
    Dim MySheet As Worksheet

    On Error Resume Next

    '************************
    'Select folder
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
    If Not objFolder Is Nothing Then
        MyPath = objFolder.self.Path & "\"
    Else
        Exit Sub
       MyPath = "D:\Folder"
    End If
    Set objFolder = Nothing
    Set objShell = Nothing

    '************************
    'List all folders

    Set AllFolders = CreateObject("Scripting.Dictionary")
    Set AllFiles = CreateObject("Scripting.Dictionary")
    AllFolders.Add (MyPath), ""
    i = 0
    Do While i < AllFolders.Count
        Key = AllFolders.keys
        MyFolderName = Dir(Key(i), vbDirectory)
        Do While MyFolderName <> ""
            If MyFolderName <> "." And MyFolderName <> ".." Then
                If (GetAttr(Key(i) & MyFolderName) And vbDirectory) = vbDirectory Then
                    AllFolders.Add (Key(i) & MyFolderName & "\"), ""
                End If
            End If
            MyFolderName = Dir
        Loop
        i = i + 1
    Loop

    'List all files
    For Each Key In AllFolders.keys
        MyFileName = Dir(Key & "*.*")
        'MyFileName = Dir(Key & "*.PDF")    'only PDF files
        Do While MyFileName <> ""
            AllFiles.Add (MyFileName), Key
            MyFileName = Dir
        Loop

    Next

    '************************
    'List all files in Files sheet

    For Each MySheet In ThisWorkbook.Worksheets
        If MySheet.Name = "Files" Then
            Sheets("Files").Cells.Delete
            F = True
            Exit For
        Else
            F = False
        End If
    Next
    If Not F Then Sheets.Add.Name = "Files"

    'Sheets("Files").[A1].Resize(AllFolders.Count, 1) = WorksheetFunction.Transpose(AllFolders.keys)
    Sheets("Files").[A1].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.Items)
    Sheets("Files").[B1].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
    Set AllFolders = Nothing
    Set AllFiles = Nothing
End Sub

J'ai essayé :

Do While MyFileName <> ""

   With MyFileName    
        If IsEmpty(.Range("a" & FirstDataRowInSourceFile)) Then
           NumOfRecordsInSourceFile = 0
        Else
           NumOfRecordsInSourceFile = _
          .Range(.Range("a" & FirstDataRowInSourceFile), .Range("a" & 
          FirstDataRowInSourceFile).End(xlDown)).Rows.Count
       End If
   End With

       If Err.Number > 0 Then
          Err.Clear
          Set sourceRange = Nothing

       On Error GoTo 0

Answer 1

'...
'...
Set AllFolders = CreateObject("Scripting.Dictionary")
Set AllFiles = CreateObject("Scripting.Dictionary")
AllFolders.Add (MyPath), ""
i = 0

Do While i < AllFolders.Count
'...
'...

Immédiatement après la création du dictionnaire, le compte sera égal à zéro, donc i < AllFolders.Count sera faux et votre boucle ne s'exécutera jamais.

Ceci devrait suffire :

Sub ListAllFilesInAllFolders()

    Dim i As Long, objFolder As Object, wsFiles As Worksheet
    Dim colFiles As Collection, arrFiles, wb, MyPath As String

    Set objFolder = CreateObject("Shell.Application").BrowseForFolder(0, "", 0, 0)
    If Not objFolder Is Nothing Then
        MyPath = objFolder.self.Path & "\"
    Else
        Exit Sub               '????????
        MyPath = "D:\Folder\"
    End If

    Set colFiles = GetMatchingFiles(MyPath, "*.csv")
    Debug.Print "Found " & colFiles.Count & " matching files"

    ReDim arrFiles(1 To colFiles.Count, 1 To 3) 'size output array
    Application.ScreenUpdating = False
    For i = 1 To colFiles.Count
        Set wb = Workbooks.Open(colFiles(i), ReadOnly:=True)
        arrFiles(i, 1) = wb.Path
        arrFiles(i, 2) = wb.Name
        arrFiles(i, 3) = wb.Sheets(1).UsedRange.Rows.Count
        wb.Close False
    Next i
    Application.ScreenUpdating = True

    On Error Resume Next 'ignore error if no match
    Set wsFiles = ThisWorkbook.Sheets("Files")
    On Error GoTo 0      'stop ignoring errors
    If wsFiles Is Nothing Then
        Set wsFiles = ThisWorkbook.Worksheets.Add()
        wsFiles.Name = "Files"
    End If

    wsFiles.Cells.ClearContents
    wsFiles.Range("a2").Resize(colFiles.Count, 3).Value = arrFiles

End Sub

'Search beginning at supplied folder root, including subfolders, for
'   files matching the supplied pattern.  Return all matches in a Collection
Function GetMatchingFiles(startPath As String, filePattern As String) As Collection 'of paths
    Dim colFolders As New Collection, colFiles As New Collection
    Dim fso As Object, fldr, subfldr, fl

    Set fso = CreateObject("scripting.filesystemobject")
    colFolders.Add startPath         'queue up root folder for processing

    Do While colFolders.Count > 0 'loop until the queue is empty
        fldr = colFolders(1)      'get next folder from queue
        colFolders.Remove 1       'remove current folder from queue
        With fso.getfolder(fldr)
            For Each fl In .Files
                If UCase(fl.Name) Like UCase(filePattern) Then  'check pattern
                    colFiles.Add fl.Path     'collect the full path
                End If
            Next fl
            For Each subfldr In .subFolders
                colFolders.Add subfldr.Path 'queue any subfolders
            Next subfldr
        End With
    Loop
    Set GetMatchingFiles = colFiles
End Function