Discussion :

[manu59173]

Bonjour

Voici ma problématique, j'aimerai scanner tous les fichiers excel dans un répertoire et pour chacun d'entre eux trouver si des liens externes existent

voici une macro pour trouver tous les fichiers excel d'un répertoire

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub Listfichier()
 
 
Dim Dossier As String, Fichier As String, i As Integer
Dossier = "C:\Users\RFRO50654\Documents\"
i = 0
Fichier = Dir(Dossier)
Do While Fichier <> ""
i = i + 1
Sheets("Feuil1").Range("A" & i) = Fichier
Fichier = Dir
Loop
End Sub

déja petit hic avec cette première macro, elle ne scanne pas les sous dossier

et la seconde qui trouve les liaisons dans un classeur actif

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub ListLinks()
    Dim xSheet As Worksheet
    Dim xRg As Range
    Dim xCell As Range
    Dim xCount As Long
    Dim xLinkArr() As String
    On Error Resume Next
    For Each xSheet In Worksheets
        Set xRg = xSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
        If xRg Is Nothing Then GoTo LblNext
        For Each xCell In xRg
            If InStr(1, xCell.Formula, "[") > 0 Then
                xCount = xCount + 1
                ReDim Preserve xLinkArr(1 To 2, 1 To xCount)
                xLinkArr(1, xCount) = xCell.Address(, , , True)
                xLinkArr(2, xCount) = "'" & xCell.Formula
           End If
        Next
LblNext:
    Next
    If xCount > 0 Then
        Sheets.Add(Sheets(1)).Name = "Link Sheet"
        Range("A1").Resize(, 2).Value = Array("Location", "Reference")
        Range("A2").Resize(UBound(xLinkArr, 2), UBound(xLinkArr, 1)).Value = Application.Transpose(xLinkArr)
        Columns("A:B").AutoFit
    Else
        MsgBox "No links were found within the active workbook.", vbInformation, "KuTools for Excel"
    End If
End Sub

Y a t'il un moyen de les combiner ?

(ces macros ne sont pas de moi, je les ai trouvé sur divers forum)

Merci d'avance

[manu59173]

Bonne nouvelle
je viens de trouver et modifier une macro pour lister tous les fichiers d'un répertoire et des sous répertoires qui le composent pour en extraire que le fichier execl

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
 
Dim i As Integer
Dim Cible As Byte
 
 
Sub listeDossiersEtSousDossiers()
    Dim Racine As String
 
    Application.ScreenUpdating = False
 
    Racine = Worksheets("Feuil1").Range("D4").Value
    Cible = nbSeparateur(Racine)
    ListeReps Racine, True
 
    Application.ScreenUpdating = True
    i = 0
End Sub
 
 
Sub ListeReps(strDossier As String, strSousDossier As Boolean)
    ' adapté de Ole P Erlandsen
    Dim fso As Object, SourceFolder As Object
    Dim SubFolder As Object
    Dim dossier As String, fichier As String
 
    On Error GoTo Fin
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = fso.GetFolder(strDossier)
 
                fichier = SourceFolder + "\"
                fichier = Dir(fichier)
 
                Do While fichier <> ""
                    If Left(Mid(fichier, InStrRev(fichier, ".") + 1), 1) = "x" Then
                    i = i + 1
                    Sheets("Feuil1").Range("A" & i) = SourceFolder + "\" + fichier
                    End If
                    fichier = Dir
                Loop
 
    If strSousDossier Then
     For Each SubFolder In SourceFolder.SubFolders
 
                fichier = SubFolder.Path + "\"
                fichier = Dir(fichier)
 
               Do While fichier <> ""
                    If Left(Mid(fichier, InStrRev(fichier, ".") + 1), 1) = "x" Then
                    i = i + 1
                    Sheets("Feuil1").Range("A" & i) = SubFolder.Path + "\" + fichier
                    End If
                    fichier = Dir
               Loop
 
      ListeReps SubFolder.Path, strSousDossier
      Next SubFolder
 
    End If
    Columns("A:A").Select
    ActiveSheet.Range("$A:$A").RemoveDuplicates Columns:=1, Header:=xlNo
    Range("D4").Select
Fin:
End Sub
 
 
Function nbSeparateur(Chemin As String) As Byte
    Dim m As Integer
    Dim Nb As Byte
 
    For m = 1 To Len(Chemin)
        If Mid(Chemin, m, 1) = "\" Then
            Nb = Nb + 1
            m = m + 1
        End If
    Next m
    nbSeparateur = Nb
End Function

il me manque plus qu'à lister les liaisons pour chacun des fichiers excel lister
me là j'aurai besoin de votre aide

[mat955]

Bonjour,

Pour ce qui est de boucler sur tous les fichiers présents dans un dossier et tous ces sous-dossiers, voici ci-dessous un exemple de procédure récursives qui fonctionne bien. Il faut au préalable activer la référence Microsoft Scripting Runtime (Outils >> Références >> cocher la référence "Microsoft Scripting Runtime")

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Dim fso As FileSystemObject, dossier As Folder, sousdossier As Folder, fichier As File
 
Sub ListeFichiers()
 
    Set fso = New FileSystemObject
    Set dossier = fso.GetFolder(Range("A1").Value)
    Call scan(dossier)
 
End Sub
 
Public Sub scan(ByVal dossier As Folder)
 
    For Each fichier In dossier.Files
        'code qui s'exécutera sur chaque fichier
        Select Case Right(fichier, 3)
            Case "xls", "lsx", "lsm"
                'Code qui s'exécutera sur les fichiers Excel
        End Select
    Next
 
    For Each sousdossier In dossier.SubFolders
        'La procédure s'appelle elle-même pour chaque sous-dossier trouvé
        Call scan(sousdossier)
    Next
 
End Sub

Dernière petite chose, utilise plutôt les balise de CODE plutôt que celle de QUOTE, elles sont faites justement pour le code

[manu59173]

Merci pour votre réponse rapide
j'ai par contre une erreur 70 accès refuser lorsque je veux scanner le dossier mes documents
vous avez peut être une idée

[mat955]

Re,

Si je me fie à l'aide Microsoft, je dirais que tu essayes d'accéder à un fichier protégé, ou quelque chose comme cela.

Peux-tu ouvrir ce fichier manuellement ?

[manu59173]

Re,

Si je me fie à l'aide Microsoft, je dirais que tu essayes d'accéder à un fichier protégé, ou quelque chose comme cela.

Peux-tu ouvrir ce fichier manuellement ?

Non pas de fichier protéger
de plus la macro que j'ai posté juste à l'instant (au dessus de la tienne) fonctionne
elle peut sans doute être améliorée (car je bidouille un peu) mais j'obtiens le résultat escomptés pour lister les fichiers excel

Mon souci reste d'interroger maintenant les fichiers que j'ai listé avec cette macro pour voir s'ils ont des liaisons ou pas (et de les lister ces liaisons)
j'ai une macro qui fait cela, mais pour le fichier en cours, il faudrait être capable de la modifier pour qu'elle scan un fichier du répertoire

en tout cas merci beaucoup pour ton aide

Manu