organiser documents office

[adkheir]

bonsoir
pour organiser les document office j'utilise cette macro que je n'arrive pas a remédier l'erreur qui se présente en l’exécutant, je compte sur vous pour éclaircir et je vous remercie vivement
voila la macro en question
code:

 Option Explicit
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean

Dim NbFichiers As Long, NbDossiers As Long
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim r As Long, rDOC As Long, rXLS As Long, rPPT As Long, sTypeFich As String
Dim TypeF() As Variant

Private Sub ListeFichiers(sDossier As String)
    DoEvents
    Application.ScreenUpdating = False
    QueryPerformanceCounter Dep

    ShFichiers.Cells.Clear
    r = 0: NbDossiers = 0: NbFichiers = 0
    rDOC = 4: rXLS = 4:  rPPT = 4

    ListeFichiersDansDossier sDossier, True
    Tri
    With ShFichiers
        .Columns("A:D").ColumnWidth = 14.86
        .Columns("A:D").Columns.AutoFit
    End With
    ActiveWindow.ScrollRow = 1
    ActiveWindow.ScrollColumn = 1

    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    With Application
        .StatusBar = "Dossiers : " & NbDossiers & " /  Fichiers : " & NbFichiers & " / " & sTypeFich & " : " & r & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
        .ScreenUpdating = True
    End With
End Sub

'   Late Binding
Private Sub ListeFichiersDansDossier(sChemin As String, bInclureSousDossiers As Boolean)
Dim FSO As Object, Dossier As Object, Fichier As String
Dim sPath As String, i As Long

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sChemin)

    Fichier = Dir$(sChemin & "\*.*")
    Do While Len(Fichier) > 0
        NbFichiers = NbFichiers + 1
        sPath = sChemin & "\" & Fichier

        For i = LBound(TypeF) To UBound(TypeF)
            If UCase(FSO.GetExtensionName(Fichier)) Like UCase(TypeF(i)) Then
                r = r + 1
                Select Case TypeF(i)
                    Case TypeF(0)
                        rDOC = rDOC + 1
                        ShFichiers.Hyperlinks.Add Anchor:=ShFichiers.Range("A" & rDOC), _
                                                  Address:=sPath, TextToDisplay:=CStr(Fichier)
                    Case TypeF(1)
                        rXLS = rXLS + 1
                        ShFichiers.Hyperlinks.Add Anchor:=ShFichiers.Range("B" & rXLS), _
                                                  Address:=sPath, TextToDisplay:=CStr(Fichier)
                    Case TypeF(2)
                        rPPT = rPPT + 1
                        ShFichiers.Hyperlinks.Add Anchor:=ShFichiers.Range("C" & rPPT), _
                                                  Address:=sPath, TextToDisplay:=CStr(Fichier)
                End Select
            End If
        Next i
        Fichier = Dir$()
        Application.StatusBar = "Dossiers : " & NbDossiers & " /  Fichiers : " & NbFichiers & " / " & sTypeFich & " : " & r
    Loop

    If bInclureSousDossiers Then
        For Each Dossier In Dossier.SubFolders
            NbDossiers = NbDossiers + 1
            ListeFichiersDansDossier Dossier.Path, True
        Next Dossier
    End If

    Set Dossier = Nothing
    Set FSO = Nothing
End Sub

Sub SelDossier()
Dim sChemin As String, i As Long

    TypeF = Array("doc*", "xls*", "ppt*")
    sTypeFich = ""
    For i = LBound(TypeF) To UBound(TypeF)
        sTypeFich = sTypeFich & " " & TypeF(i)
    Next i

    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Dossier à traiter"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then ListeFichiers .SelectedItems(1)
        ShFichiers.Range("A1").Select
    End With
End Sub

Sub Tri()
    With ShFichiers
        .Range("A5:A" & Rows.Count).Sort Key1:=Range("A5"), Order1:=xlAscending
        .Range("B5:B" & Rows.Count).Sort Key1:=Range("B5"), Order1:=xlAscending
        .Range("C5:C" & Rows.Count).Sort Key1:=Range("C5"), Order1:=xlAscending
    End With
End Sub >

 

[Staple1600]

Re : organiser documents office

Bonjour à tous

adkheir
Sur quelle ligne de code l'erreur se produit-elle?
Et quel message d'erreur apparait?

 

[Paf]

Re : organiser documents office

Bonjour à tous,

après avoir parcouru le code, ShFichiers est a priori une variable worksheet qui n'est instanciée nulle part.
Mais le code est-il complet?

Bonne fin de journée

Edit; Pas vu la date initiale de la discussion. Le soucis doit-être résolu.

 

[Staple1600]

Re : organiser documents office

Bonjour Paf

j'ai présumé que c'était peut-etre le code name de la feuille, non ?

 

[Paf]

Re : organiser documents office

Bonsoir Staple1600,

Peut_être, mais je crois qu'on ne le saura pas .

 

[adkheir]

Re : organiser documents office

Bonjour et bonne année a tous
je suis un peu nul en vba mais tout ce que recherche c'un code qui peut balayer tout le disque pour créer des liens de mes fichiers .doc* ou .xls* en vue de les retrouver plus facilement pour Microsoft office 2003 , 2010 et open office
cordialement