Dépassement de capacité

Bonjour,

lorsque je lance ma macro et comme j'ai + 40000 fichiers dans des répertoires, j'ai un dépassement de capacité.

Comment peut on contourner ce problème.

Option Explicit
Dim Data()
Dim NBdata As Integer
Sub Lecture()
Dim LeChemin  As String
Dim J As Long

  Application.ScreenUpdating = False
  LeChemin = Cells(1, 7)
  If LeChemin = "" Then
        MsgBox ("Le chemin de sauvegarde doit etre defini dans la cellule G1 !")
      Exit Sub
    End If

  If LeChemin = "" Then Exit Sub
  LireRepertoir LeChemin, True

  With Sheets("Liste Fichiers")
    .Range("A1").Resize(UBound(Data, 2), 3) = Application.Transpose(Data)
  End With

End Sub
'Obtenir tous les fichiers d'un répertoire et éventuellement des sous-répertoires
'Si SousRep = true
'Le répertoire source doit être dans Rep
Public Function LireRepertoir(ByVal Rep As String, Optional SousRep As Boolean) As Integer
Dim Obj, RepP, F, S, sf, F1, Fsous
Dim i As Integer, Ext As String
Dim Chem As String
Dim T As Double

  NBdata = 1
  ReDim Data(1 To 4, 1 To NBdata)
    Set Obj = CreateObject("Scripting.FileSystemObject")
    Set RepP = Obj.Getfolder(Rep)
    Chem = Rep: If Right(Chem, 1) <> "\" Then Chem = Chem & "\"

    Set sf = RepP.subfolders
    Set F = RepP.Files
    GoSub RempliData                        'les fichiers du répertoire principal
   If SousRep Then                         'les fichiers des sous-répertoires
       For Each Fsous In sf
            Set RepP = Fsous
            Set F = RepP.Files
            GoSub RempliData
        Next Fsous
    End If
Exit Function
'**********************************************************************
RempliData:
  For Each F1 In F
    NBdata = NBdata + 1
    ReDim Preserve Data(1 To 4, 1 To NBdata)
    Data(1, NBdata) = F1.ParentFolder & "\" & F1.Name
    Next F1

Return

End Function

Merci de votre retour

Bonsoir

Remplaces:

Dim NBdata As Integer par Dim NBdata As Long

A tester. Cdlt

Erreur de débutant

Merci beaucoup