Recherche de valeur dans classeur entier

[ludo93]

Bonjour

Je voudrais faire une synthèse d’un classeur excel qui regroupe normalement une centaine d’onglet

Ci-joint un extrait

Je voudrais faire une synthèse de certains éléments et là je ne sais pas comment l’aborder soit la synthèse dans un classeur externe qui va chercher les éléments dans le fichier (en vba ou en formule)


Merci de votre retour et de votre aide je sais que j’en demande beaucoup au moins de mon point de vue

 

[DoubleZero]

Bonjour, ludo93, le Forum,

Comme ceci ?

Option Explicit
Sub Synthèse()
    Dim o As Object
    With Application: .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False: End With
    Sheets("synthese").Activate
    Range(Range("a3"), Range("f3").End(xlDown)).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants).Clear
    For Each o In Worksheets
        If o.Name <> "synthese" And o.Range("a5") = "Nom : " Then
            o.Range("b5").Copy Sheets("synthese").Range("a" & Rows.Count).End(xlUp)(2)
            o.Range("d22:h22").Copy Sheets("synthese").Range("b" & Rows.Count).End(xlUp)(2)
        End If
    Next
    Range("a2").CurrentRegion.Borders.Value = 1
    With Application: .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True: End With
End Sub

A bientôt

 

[ludo93]

Merci doublezero pour des efforts soit j'ai louper quelque chose mais quand je lance la macro il efface les donner
Peut être que je me suis mal exprimer sur ceux que le résultat de fait resortir

Merci de ton aide

 

[DoubleZero]

Re-bonjour,

... quand je lance la macro il efface les donner...

Cela est dû au nombre de caractères présents en a5 "Nom : " ou "Nom :".

Que donne le code suivant ?

Option Explicit
Sub Synthèse()
    Dim o As Object
    With Application: .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False: End With
    Sheets("synthese").Activate
    On Error Resume Next
    Range(Range("a3"), Range("f3").End(xlDown)).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants).Clear
    On Error GoTo 0
    For Each o In Worksheets
        If o.Name <> "synthese" And o.Range("a5") Like "Nom*" Then
            o.Range("b5").Copy Sheets("synthese").Range("a" & Rows.Count).End(xlUp)(2)
            o.Range("d22:h22").Copy Sheets("synthese").Range("b" & Rows.Count).End(xlUp)(2)
        End If
    Next
    Range("a2").CurrentRegion.Borders.Value = 1
    With Application: .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True: End With
End Sub

A bientôt

 

[ludo93]

Merci ca fonctionne bien

 

[ludo93]

Re

Ca fonctionner trop bien et j'ai voulue l'adapter a un autre cas et la je me suis aperçu que si une des valeurs n'est pas rempli qu'il revenait sur la premier ligne et non sur la ligne correspondante

Merci d'avance

 

[DoubleZero]

Bonjour, ludo93, le Forum,

... j'ai voulue l'adapter a un autre cas et la je me suis aperçu...

Voici une adaptation.

Option Explicit
Sub Synthèse_autre_cas()
    Dim o As Object, sy As Object
    Set sy = Sheets("synthese")
    With Application: .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False: End With
    sy.Activate
    Range("a3:m65000").Clear
    For Each o In Worksheets
        If o.Name <> "synthese" And o.Range("A5") Like "NOM*" Then
            o.Range("d5").Copy sy.Range("a" & Rows.Count).End(xlUp)(2)
            o.Range("e88").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 1)
            o.Range("d33").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 2)
            o.Range("e90").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 3)
            o.Range("e132").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 4)
            o.Range("f148").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 5)
            o.Range("d144").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 6)
            o.Range("e162").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 7)
            o.Range("e143").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 8)
            o.Range("d149").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 9)
            o.Range("d150").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 10)
            o.Range("d151").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 11)
            o.Range("f143").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 12)
        End If
    Next
    Range("a3").CurrentRegion.Borders.Value = 1
    With Application: .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True: End With
End Sub

A bientôt

 

[ludo93]

Re merci fonctionne a merveille pour ce tableau

 

[ludo93]

Bonjour
Helas je reviens sur le premier tableau après l'avoir tester sur l'ensemble du fichier il y a eu une anomalie qui est est ressortie dans plusieurs cas.
Dans plusieurs fiches ils n'ont pas les même lignes ceux qui provoque un décalage des valeurs.

Merci d'avance d'un miracle

 

[DoubleZero]

Bonjour, ludo93, le Forum,

... Merci d'avance d'un miracle

Nous sommes loin des demandes formulées en #1, puis en #6 .

Attendons l'aide d'autres membres pour le "miracle".

A bientôt

 

[ludo93]

Merci d'avoir jeter un oeil au cas je sais que par rapport a la demande initiale. Mais hélas s'est une foie avec le fichier complet que ce décalage de ligne est apparue.

J’espère que quelqu’un aura une idée lumineuse pour résoudre ce case tête

Merci d'avance de votre aide