Pb de résultat obtenu avec une macro...

[mentos64]

Bonjour,

J'ai réalisé une macro qui parcourt des répertoires et sous-répertoires. Dès qu'elle trouve une classeur excel alors je lui demande (par le biais d'une fonction Parcours_Classeur_Excel) de chercher de regarder les feuilles du classeur actif s'il trouve "Designation" sur une certaine plage. Si c'est le cas, il compare les intitulés de la colonne associée avec une autre colonne d'un autre classeur.
Ma macro fonctionne et doit m'afficher la liste des intitulés manquant et le nom du fichier auxquels ils se rapportent.
Le souci que j'ai et que dès que je relance ma macro, elle trouve toujours de nouveaux intitulés alors que les répertoires sont les mêmes... Pourquoi ?

Voici la macro :

Option Explicit
Public Const MonRepertoire = "U:\PersonalData\PM\Méthode leak index\Compare+Filiales\"
Sub ListeFichiersRepert()

'activer la reference Microsoft scripting Runtime

Dim fso As Scripting.FileSystemObject

Dim Source As String, F3 As Folder, x As Integer, F5 As Folder, F As File, F2 As File, F4 As File
Dim F1 As Folder, F6 As File, rep2 As String, F7 As File, F8 As Folder

Set fso = CreateObject("Scripting.FileSystemObject")

Source = MonRepertoire
x = 1


For Each F In fso.GetFolder(MonRepertoire).Files
If Right(F, 3) = "xls" Then
Cells(x, 10).Value = Parcours_Classeur_Excel(F)
x = x + 1
End If
Next F


For Each F1 In fso.GetFolder(MonRepertoire).SubFolders

For Each F2 In fso.GetFolder(F1 & "\").Files
If Right(F2, 3) = "xls" Then
Cells(x, 10).Value = Parcours_Classeur_Excel(F2)
x = x + 1
End If
Next F2

For Each F3 In fso.GetFolder(F1 & "\").SubFolders

For Each F4 In fso.GetFolder(F3 & "\").Files
If Right(F4, 3) = "xls" Then
Cells(x, 10).Value = Parcours_Classeur_Excel(F4)
x = x + 1
End If
Next F4

For Each F5 In fso.GetFolder(F3 & "\").SubFolders

For Each F7 In fso.GetFolder(F5 & "\").Files
If Right(F7, 3) = "xls" Then
Cells(x, 10).Value = Parcours_Classeur_Excel(F7)
x = x + 1
End If
Next F7

For Each F8 In fso.GetFolder(F5 & "\").SubFolders

x = x + 1

For Each F6 In F8.Files

If Right(F6, 3) = "xls" Then
Cells(x, 10).Value = Parcours_Classeur_Excel(F6)
x = x + 1
End If
Next F6

x = x - 1

Next F8

Next F5

Next F3

Next F1

End Sub

Private Function Parcours_Classeur_Excel(Fichier As File) As Variant

Dim Fich As String

Dim Classeur1 As Workbook
Dim Classeur2 As Workbook

Set Classeur1 = Workbooks("leaks index.xls")

Dim Feuille As Worksheet
Dim F1 As Worksheet

Set F1 = Classeur1.Worksheets("all_type")

Dim lig As Integer
Dim col As Integer
Dim colonneDesign As Integer
Dim ligneDesign As Integer
Dim lig1 As Integer
Dim ln1 As Integer
Dim i As Integer

ln1 = 1

Set Classeur2 = Workbooks.Open(Fichier)

For Each Feuille In Classeur2.Worksheets

colonneDesign = 0
ligneDesign = 0

Feuille.Activate

'détection de la colonne contenant les intitulés des systèmes
For lig = 1 To 10
For col = 1 To 10

If TypeName(Feuille.Cells(lig, col).Value) = "String" Then

If (InStr(Feuille.Cells(lig, col).Value, "Designation") <> 0 Or InStr(Feuille.Cells(lig, col).Value, "Désignation")) Then
colonneDesign = col
ligneDesign = lig + 2
End If

End If

Next col
Next lig

' si on se trouve dans une feuille sur laquelle la comparaison va se faire
If colonneDesign <> 0 And ligneDesign <> 0 Then

'détection des systèmes manquant dans leaks index

For i = ligneDesign To 200

For lig1 = 7 To 489

If Feuille.Cells(i, colonneDesign).Value = F1.Cells(lig1, 2).Value Then
Exit For
End If

If lig1 = 489 Then
F1.Cells(ln1, 6).Value = Feuille.Cells(i, colonneDesign).Value
F1.Cells(ln1, 7).Value = Fichier.Name
ln1 = ln1 + 1
End If

Next lig1

Next i

End If

Next Feuille

Classeur2.Close True
Set Classeur2 = Nothing
'Fich = Fichier
'Fich = Dir

End Function

Merci d'avance