recherche sur +sieurs classeurs

JC de Lorient · 24 Mars 2005

Bonsoir le forum

je souhaiterais une petite aide dans la mesure du faisable!

pour mon job je gère une centaine de classeurs XL dans un même répertoire, ce que je voudrais obtenir :

je regarde dans tous mes classeurs la colonne B, si dans cette colonne je trouve la valeur 'ma valeur' alors au choix : lister les classeurs ou je trouve cette valeur ou me lister la valeur de la cellule a gauche de 'ma valeur'

ça sent le VBA et même si je progresse un peu je suis loin d'arriver à mes fins

merci a vous

JC

myDearFriend! · 24 Mars 2005

Bonsoir JC, le Forum.

Ci-joint un fichier avec une méthode possible...

On part de l'hypothèse où ce classeur est situé dans le répertoire à 'scanner' :

Public Sub ChercheMaValeur()
Dim Fichiers As Object, Classeur As Object, N As Integer, R As Integer
Dim ListeClasseurs As New Collection
Dim ListeRetenus() As Variant
Dim C As Range
Dim MaValeur As Variant
Dim Chemin As String
      'Définir de la valeur à rechercher
      MaValeur = ThisWorkbook.Sheets('Feuil1').Range('B24').Value
      If MaValeur = '' Then
            MsgBox 'Saisissez une valeur à rechercher !'
            Exit Sub
      End If
      'Lister les Classeurs du dossier
      Application.ScreenUpdating = False
      Chemin = ThisWorkbook.Path
      ThisWorkbook.Sheets('Résultats').Rows('2:65536').Delete
      Set Fichiers = CreateObject('Scripting.FileSystemObject').getfolder(Chemin).Files
      For Each Classeur In Fichiers
            If Right(Classeur.Name, 3) = 'xls' Then
                  If Classeur.Name <> ThisWorkbook.Name Then
                        ListeClasseurs.Add Classeur.Name
                  End If
            End If
      Next
      'Rechercher la valeur dans chaque classeur
      For N = 1 To ListeClasseurs.Count
            Application.EnableEvents = False
            Workbooks.Open Chemin & '\' & ListeClasseurs(N)
            Application.EnableEvents = True
            With ActiveWorkbook
                  Set C = .Sheets(1).Columns(2).Find(MaValeur, LookIn:=xlValues)
                  If Not C Is Nothing Then
                        R = R + 1
                        ReDim Preserve ListeRetenus(1 To 2, 1 To R)
                        ListeRetenus(1, R) = ListeClasseurs(N)
                        ListeRetenus(2, R) = C.Offset(0, -1).Value
                  End If
                  .Close False
            End With
      Next N
      'MAJ de la liste des classeurs retenus
      ListeRetenus = Application.Transpose(ListeRetenus)
      With ThisWorkbook.Sheets('Résultats')
            .Activate
            .Range(.Cells(2, 1), .Cells(UBound(ListeRetenus, 1) + 1, _
                  UBound(ListeRetenus, 2))).Value = ListeRetenus
            .Columns('A:B').AutoFit
      End With
      Application.ScreenUpdating = True
      MsgBox UBound(ListeRetenus, 1) & ' Classeurs contenant ''' & MaValeur & _
            ''' en colonne B.'
End Sub

Cordialement.
[file name=ScanFichiers.zip size=17708]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/ScanFichiers.zip[/file]

JC de Lorient · 25 Mars 2005

Bonjour Didier, le forum

ben quoi dire? sinon merci !!!!!!

tjrs aussi halluciné par vos performances !!

juste une petite chose concernant ce code, ce que je n'ai pas dit, tous mes classeurs sont avec liaisons et a chaque analyse de classeur XL me demande si je mets a jour ou pas les liaisons.
Est ce possible de 'sauter' cette étape ?

encore merci

JC

JC de Lorient · 25 Mars 2005

re tout le monde

je remets un petit post car suis passé en 2ème page bien avancée ! en espérant que qqu'1 puisse me venir en aide

merci encore

JC

myDearFriend! · 25 Mars 2005

Bonsoir JC, le Forum.

Dans ce cas, je pense qu'il convient d'utiliser la propriété AskToUpdateLinks de l'objet Application comme suit :

Public Sub ChercheMaValeur()
Dim Fichiers As Object, Classeur As Object, N As Integer, R As Integer
Dim ListeClasseurs As New Collection
Dim ListeRetenus() As Variant
Dim C As Range
Dim MaValeur As Variant
Dim Chemin As String
      'Définir de la valeur à rechercher
      MaValeur = ThisWorkbook.Sheets('Feuil1').Range('B24').Value
      If MaValeur = '' Then
            MsgBox 'Saisissez une valeur à rechercher !'
            Exit Sub
      End If
      'Lister les Classeurs du dossier
      Application.AskToUpdateLinks = False
      Application.ScreenUpdating = False
      Chemin = ThisWorkbook.Path
      ThisWorkbook.Sheets('Résultats').Rows('2:65536').Delete
      Set Fichiers = CreateObject('Scripting.FileSystemObject').getfolder(Chemin).Files
      For Each Classeur In Fichiers
            If Right(Classeur.Name, 3) = 'xls' Then
                  If Classeur.Name <> ThisWorkbook.Name Then
                        ListeClasseurs.Add Classeur.Name
                  End If
            End If
      Next
      'Rechercher la valeur dans chaque classeur
      For N = 1 To ListeClasseurs.Count
            Application.EnableEvents = False
            Workbooks.Open Chemin & '\' & ListeClasseurs(N)
            Application.EnableEvents = True
            With ActiveWorkbook
                  Set C = .Sheets(1).Columns(2).Find(MaValeur, LookIn:=xlValues)
                  If Not C Is Nothing Then
                        R = R + 1
                        ReDim Preserve ListeRetenus(1 To 2, 1 To R)
                        ListeRetenus(1, R) = ListeClasseurs(N)
                        ListeRetenus(2, R) = C.Offset(0, -1).Value
                  End If
                  .Close False
            End With
      Next N
      'MAJ de la liste des classeurs retenus
      ListeRetenus = Application.Transpose(ListeRetenus)
      With ThisWorkbook.Sheets('Résultats')
            .Activate
            .Range(.Cells(2, 1), .Cells(UBound(ListeRetenus, 1) + 1, _
                  UBound(ListeRetenus, 2))).Value = ListeRetenus
            .Columns('A:B').AutoFit
      End With
      Application.ScreenUpdating = True
      Application.AskToUpdateLinks = True
      MsgBox UBound(ListeRetenus, 1) & ' Classeurs contenant ''' & MaValeur & _
            ''' en colonne B.'
End Sub

Cordialement.

JC de Lorient · 26 Mars 2005

Bonjour MDF, le forum

juste une question Didier : c toi qui a inventé le VBA ou quoi !!!! lol

ça marche à merveille
c un peu long en taritement mais quel gain de temps !!

dix mille merci

bonne journée et très bon week end Pascal

JC

KIM · 5 Octobre 2005

Bonjour mDF, le forum,
Ce code est très intéressant et je l'utilise, merci .
Actuellement mon besoin est de recopier toute la ligne avec le meme format d'origine (gras, couleur , fond ) pour chaque cellule.
Comment modifier cette ligne?
ListeRetenus(2, R) = C.Offset(0, -1).Value
Merci d'avance
Amicalement
KIM

recherche sur +sieurs classeurs

JC de Lorient

Guest

myDearFriend!

XLDnaute Barbatruc

Pièces jointes

JC de Lorient

Guest

JC de Lorient

Guest

myDearFriend!

XLDnaute Barbatruc

JC de Lorient

Guest

KIM

XLDnaute Accro

Discussions similaires