problème macro

[jean123]

Salut tout le monde

j'ai un souci sur une macro avec "Application.FileSearch" qui n'est plus fonctionnel sous excel 2010

comment aboutir au même résultat ????
Voici le code

Private Sub cmdRecuperation_Click()
    Dim lgWBF As Long
    Dim strWBC As String
    Dim strWBF As String
    Dim lgWSC As Long
    Dim lgWSF As Long
    Dim strWSF As String
    Dim bTrouve As Boolean
   
    Application.ScreenUpdating = False
   
    ' Effacer le contenu des colonnes B et C
    For lgWSC = 1 To Worksheets.Count
        With Worksheets(lgWSC)
            .Range("A1:DD456").ClearContents
            .Range("A1:DD456").Value = 0
        End With
    Next lgWSC
    ' Nom du classeur
    strWBC = ActiveWorkbook.Name

    ' Récupération de tous les fichiers "FICHE_DE_POSTE_..."
    With Application.FileSearch
        .NewSearch
        .LookIn = ThisWorkbook.Path
        .Filename = "bob*" & ".xls"
        .FileType = msoFileTypeExcelWorkbooks
        .Execute
   
        ' Boucle du premier au dernier fichier
        For lgWBF = 1 To .FoundFiles.Count
            If UCase(ThisWorkbook.Path & "\" & strWBC) <> UCase(.FoundFiles(lgWBF)) Then
                ' Ouvrir le fichier
                Workbooks.Open .FoundFiles(lgWBF)
                ' Récupération du nom du classeur ouvert
                strWBF = ActiveWorkbook.Name
               
                ' Boucle de la première à la dernière feuille
                For lgWSF = 1 To Workbooks(strWBF).Worksheets.Count
                    Workbooks(strWBF).Activate
                    Worksheets(lgWSF).Activate
                    strWSF = Worksheets(lgWSF).Name
                   
                    bTrouve = False
                    ' Recherche de la feuille dans le classeur de consolidation
                    For lgWSC = 1 To Workbooks(strWBC).Worksheets.Count
                        If Workbooks(strWBC).Worksheets(lgWSC).Name = strWSF Then
                            bTrouve = True
                            Exit For
                        End If
                    Next lgWSC
                   
                    ' Feuille trouvée dans le classeur consolidation
                    If bTrouve = True Then
                        ' Copier les colonnes L et M de la fiche
                        Worksheets(lgWSF).Range("L6:M18").Copy
                        ' Activer le classeur de consolidation
                        Workbooks(strWBC).Activate
                        ' Sélectionner la feuille de destination
                        Worksheets(strWSF).Activate
                        Worksheets(strWSF).Range("B6").Select
                        ' Coller en additionnant les valeurs
                        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, _
                            SkipBlanks:=False, Transpose:=False
                        Application.CutCopyMode = False
                    End If
                Next lgWSF
           
                ' Fermeture du classeur
                Workbooks(strWBF).Close
            End If
        Next lgWBF
    End With
   
    Application.ScreenUpdating = True
End Sub

 

[Roland_M]

Bonjour,

effectivement c'est depuis 2007 !
exemple d'utilisation avec cette cette macro à étudier !
attention elle ne peut fonctionner en l'état car il y a des variables non initialisées !

Sub RechercheFichier()
Chemin = "C:\Chemin\"
FindNom = "NomFichier" ' nom complet ou partie
Extension = "xls"  ' ou *
DirFileName = FindRecherche & "." & Extension

Dim FSO As FileSystemObject, SourceFolder As Folder, SubFolder As Folder, FileItem As File
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(Chemin)

DernLig = ActiveSheet.Columns(NoDeCol).Rows(Rows.Count).End(xlUp).Row
Fichier = Dir(Chemin & DirFileName)
Do While Fichier > ""
   If InStr(LCase(Fichier), LCase(FindRecherche)) Then
      Set FileItem = FSO.GetFile(Chemin & Fichier)
      I = InStrRev(Fichier, "."): If I Then Fichier = Left(Fichier, I - 1)
      Cells(DernLig, NoDeColFich) = Fichier
      Cells(DernLig, NoDeColDate) = FileItem.DateLastModified
      ActiveSheet.Hyperlinks.Add Cells(DernLig, NoDeColLien), FileItem.Path
      TotFichTrouve = TotFichTrouve + 1: DernLig = DernLig + 1
   End If
   Fichier = Dir
Loop
Set FSO = Nothing: Set SourceFolder = Nothing: Set SubFolder = Nothing: Set FileItem = Nothing
End Sub

 

[jean123]

nickel merci c'est une bonne base de travail

 

[gilbert_RGI]

Bonjour,
il existe un complément pour remplacer Application.FileSearch
http://silkyroad.developpez.com/vba/classefilesearch/