[PR-2010] VBA EXCEL: l'indice 9 n'appartient pas à la selection

Bonjour,

J'utilise une macro qui extrait des valeurs à partir de plusieurs fichiers Excel qui existent dans plusieurs sous dossiers.
Le problème c'est que durant l'extraction un message d'erreur apparait et qui indique ("l'indice n'appartient pas à la selection") et après avoir cliquer sur OK elle change completement de dossier et ignore le reste des fichiers.par exemple sur le dossier "Mars" lorsque le message d'erreur apparait sur le premier fichier (01/03/2015) la macro ne continu pas à extraire les info du reste des fichiers de Mars (02/03..31/03/2015)mais elle saute vers le dossier de Avril. je ne sais pas pourquoi elle ne continu pas à fouiller le reste des fichiers du mois de Mars.

ci-dessous mon code:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
Sub Facture()
    Dim nbLignes As Long
    Dim Chemin
    nbLignes = Sheets("Facture").Cells(Rows.Count, "A").End(xlUp).Row
 
 
    Chemin = BrowseForFolder("C:\Users\seb\Desktop")  'Changer le C pour autre chose si nécessaire
 
 
    ImportFiles Chemin   'Changer au besoin
 
    Sheets("Facture").Sort.SortFields.Add Key:=Range("A30:A" & nbLignes), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets("Facture").Sort
        .SetRange Range("A30:AN" & nbLignes)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
 
    MsgBox "Terminé"
 
End Sub
 
Sub ImportFiles(varPath As Variant)
    Dim nbLignes As Long
    Dim varFile As Variant
    Dim objColl As Collection
 
    On Error GoTo Erreur
 
    Set objColl = New Collection
 
    If Right(varPath, 1) <> "\" Then varPath = varPath & "\"
 
    varFile = Dir(varPath, vbDirectory + vbArchive)
    Do While varFile <> ""
        'Stocke le répertoire
        If GetAttr(varPath & varFile) = vbDirectory Then
            If Left(varFile, 1) <> "." Then
                objColl.Add varPath & varFile
            End If
 
        'Travailler avec le fichier
        ElseIf LCase(Right(varFile, 3)) = "xls" Or LCase(Right(varFile, 4)) = "xlsx" Or LCase(Right(varFile, 4)) = "xlsm" Then
            'Détermine la première ligne vide du classeur Résultats
            nbLignes = ThisWorkbook.Sheets("Facture").Cells(Rows.Count, "A").End(xlUp).Row + 1
 
 
            'Ouvrir le fichier, copier les données et le fermer
            Application.DisplayAlerts = False
            Workbooks.Open varPath & varFile, , True
            Application.DisplayAlerts = False
 
 
             ActiveWorkbook.Sheets("Tableau Feuil1").Range("D11").Copy ThisWorkbook.Sheets("Facture").Range("B" & nbLignes)
            ActiveWorkbook.Sheets("Tableau Feuil1").Range("F11").Copy ThisWorkbook.Sheets("Facture").Range("C" & nbLignes)
            ActiveWorkbook.Sheets("Tableau Feuil1").Range("D12").Copy ThisWorkbook.Sheets("Facture").Range("D" & nbLignes)
 
 
            ActiveWorkbook.Close False
        End If
        varFile = Dir
    Loop
 
    For Each varFile In objColl
        ImportFiles varFile
    Next
 
    Set objColl = Nothing
 
    Exit Sub
 
Erreur:
    MsgBox Err.Number & vbCrLf & Err.Description
End Sub
 
 
 
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
    Dim ShellApp As Object
 
    Set ShellApp = CreateObject("Shell.Application"). _
        BrowseForFolder(0, "Please choose a folder", 0, CVar(OpenAt))
 
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
 
    Set ShellApp = Nothing
 
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Erreur
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Erreur
        Case Else
            GoTo Erreur
    End Select
 
    Set ShellApp = Nothing
 
    Exit Function
 
Erreur:
    BrowseForFolder = False
 
End Function

Merci pour votre aide.