soucis écriture VBA

JC de Lorient · 12 Octobre 2005

Bonsoir le forum,

L'exellent Mydearfriend m'a créé un code VBA qui évidemment marche a merveille. J'ai souhaité rajouter une valeur (içi en ligne (1))
Mais ça buge en ligne (2)
Merci a celui ou celle qui m'apportera la solution
Voiçi un extrait du code

'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(3).Find(MaValeur, LookIn:=xlValues)
If Not C Is Nothing Then
R = R + 1
ReDim Preserve ListeRetenus(1 To 3, 1 To R)
ListeRetenus(1, R) = ListeClasseurs(N)
ListeRetenus(2, R) = C.Offset(0, -1).Value
(1) ListeRetenus(3, R) = C.Offset(0, 10).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
(2) .Range(.Cells(2, 1), .Cells(UBound(ListeRetenus, 1) + 1, _
UBound(ListeRetenus, 2), UBound(ListeRetenus, 3))).Value = ListeRetenus
.Columns('A:C').AutoFit
End With

JC

bebere · 12 Octobre 2005

bonsoir Jc de Lorient
écrire la ligne 2 comme suit
.Range(.Cells(2, 1), .Cells(UBound(ListeRetenus, 1) + 1, _
UBound(ListeRetenus, 2))).Value = ListeRetenus
à bientôt

JC de Lorient · 12 Octobre 2005

Salut Bébére et re le forum

ça marche mais c ce que m'avais fé MDF
en fait moi ce que je recherche c'est d'afficher la 3ème valeur
celle ci : ListeRetenus(3, R) = C.Offset(0, 10).Value

je ne sais pas si je suis suffisamment clair dans mes explications

merci tout de même !

JC

Bebere · 12 Octobre 2005

re
normalement tu l'as avec

Range(.Cells(2, 1), .Cells(UBound(ListeRetenus, 1) + 1, _
UBound(ListeRetenus, 2))
ligne suivante essaye comme suit,si ne va pas remet comme avant
With ActiveWorkbook.Sheets(1)
Set C = .Columns(3).Find(MaValeur, LookIn:=xlValues)
If Not C Is Nothing Then
R = R + 1
ReDim Preserve ListeRetenus(1 To 3, 1 To R)
ListeRetenus(1, R) = ListeClasseurs(N)
ListeRetenus(2, R) = C.Offset(0, -1).Value
(1) ListeRetenus(3, R) = C.Offset(0, 10).Value
End If
.Close False
Next N
End With
ligne plus haut end with doit être après next n
à+ 🙂

myDearFriend! · 13 Octobre 2005

Bonsoir JC de lorient, bebere,

Bebere avait raison dans son 1er Post, il convient de laisser la ligne :

.Range(.Cells(2, 1), .Cells(UBound(ListeRetenus, 1) + 1, _
UBound(ListeRetenus, 2))).Value = ListeRetenus

comme à l'origine. Tu obtiendras bien ta 3ème valeur dans la 3ème colonne des résultats sans changer cette ligne.

Le code entier devrait donc être :

      '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(3).Find(MaValeur, LookIn:=xlValues)
                  If Not C Is Nothing Then
                        R = R + 1
                        ReDim Preserve ListeRetenus(1 To 3, 1 To R)
                        ListeRetenus(1, R) = ListeClasseurs(N)
                        ListeRetenus(2, R) = C.Offset(0, -1).Value
                        ListeRetenus(3, R) = C.Offset(0, 10).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

Si ça ne marche toujours pas, c'est peut-être parce que tu as mis un 3 à la place du 2 (qu'il y avait aussi à l'origine) dans cette ligne :

Set C = .Sheets(1).Columns(2).Find(MaValeur, LookIn:=xlValues)

Cordialement,

JC de Lorient · 13 Octobre 2005

Bonjour a tous
Bebere, MDF je viens de prendre connaissance de vos réponses
je n'ai pas le temps de mettre en oeuvre pour le moment
je regarde tout ça et nul doute que ça ira !!

mille mercis

JC

JC de Lorient · 13 Octobre 2005

re le forum

Evidemment que ça marchait pas !!!!
je demandais la 10ème valeur alors que je voulais la 7ème !!!!

Par contre je découvre un autre soucis
dans mes classeurs de recherche il peut arriver d'avoir plusieurs fois la valeur recherchée (même valeur mais a des dates différente) et lors du résultat ça m'affiche que la 1ère valeur trouvée
est ce solutionnable ?
si oui que faudrait il changer dans le code ?

merci d'avance

JC

myDearFriend! · 13 Octobre 2005

Bonsoir JC, bebere,

Tu trouveras ci-joint ton précédent exemple adapté en conséquence...

J'ai modifié la procédure 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, MemoAdresse As String
      'Définir de la valeur à rechercher
      MaValeur = ThisWorkbook.Sheets('XLD').Range('B32').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.Sheets(1).Columns(2)
                  Set C = .Find(MaValeur, LookIn:=xlValues)
                  If Not C Is Nothing Then
                        'Mémorise l'adresse de la 1ère cellule cible rencontrée
                        MemoAdresse = C.Address
                        Do
                              R = R + 1
                              ReDim Preserve ListeRetenus(1 To 3, 1 To R)
                              ListeRetenus(1, R) = ListeClasseurs(N)
                              ListeRetenus(2, R) = C.Offset(0, -1).Value
                              ListeRetenus(3, R) = C.Offset(0, 7).Value
                              Set C = .FindNext(C)
                        Loop While Not C Is Nothing And C.Address <> MemoAdresse
                  End If

            End With
            ActiveWorkbook.Close False
      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 'La valeur ''' & MaValeur & ''' a été trouvée ' & UBound(ListeRetenus, 1) & ' fois en colonne B.'
End Sub

- En gras les lignes modifiées.
- En rouge les éléments à adapter le cas échéant.

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

Message édité par: myDearFriend!, à: 13/10/2005 21:45

JC de Lorient · 15 Octobre 2005

Bonjour à atous !!

merci bcp MDF pour avoir adapter mon code !!

ça fonctionne a merveille mé ça j'en avais aucun doute !!!

JC

soucis écriture VBA

JC de Lorient

Guest

bebere

Guest

JC de Lorient

Guest

Bebere

XLDnaute Barbatruc

myDearFriend!

XLDnaute Barbatruc

JC de Lorient

Guest

JC de Lorient

Guest

myDearFriend!

XLDnaute Barbatruc

Pièces jointes

JC de Lorient

Guest

Discussions similaires

soucis écriture VBA

JC de Lorient

Guest

bebere

Guest

JC de Lorient

Guest

Bebere

XLDnaute Barbatruc

myDearFriend!

XLDnaute Barbatruc

JC de Lorient

Guest

JC de Lorient

Guest

myDearFriend!

XLDnaute Barbatruc

Pièces jointes

JC de Lorient

Guest

Discussions similaires

Privacy & Transparency

Privacy & Transparency