Autres recherche sur plusieurs colonnes excel 2007

[chilo]

Bonsoir le forum

J'appelle de nouveau à l'aide pour résoudre un petit problème

je souhaite faire une recherche sur plusieurs feuilles et colonnes
des chiffres en surbrillance et les retourner dans une feuille appelée récapitulation
avec le numéro du compteur en vba si possible
en vous remerciant par avance pour votre aide

 

[job75]

Bonjour chilo,

Ce n'est pas très clair.

En Feuil3 plage B19:F19 on a la suite 1-2-5-4-3 au lieu de 1-2-3-4-5.

C'est une erreur de votre part ou cette plage correspond aux critères de recherche ?

A+

 

[sylvanu]

Bonjour Chilo, Job,
Un essai en PJ.
J'ai mis la liste des N° à chercher dans la feuille Récapitulation, ce qui me semblait plus naturel.

 

[sylvanu]

Re chilo, Job,
Très pertinente remarque Job.
Je pensais que cela ne pouvait être que dans l'ordre.
En PJ si les nombres recherchés sont dans un total désordre.

 

[job75]

Voyez le fichier joint et cette macro dans le code de la feuille "Récapitulation" :

Private Sub Worksheet_Activate()
Dim critere, ub%, resu(), w As Worksheet, tablo, i&, copie As Boolean, j%, n&
critere = Feuil1.[B4:F4] 'vecteur ligne, plus rapide
ub = UBound(critere, 2)
ReDim resu(1 To Rows.Count, 1 To ub + 3)
For Each w In Worksheets
    If w.Name <> Me.Name Then
        tablo = w.Range("A6").CurrentRegion.Resize(, ub + 2) 'matrice, plus rapide
        For i = 1 To UBound(tablo)
            copie = True
            For j = 1 To ub
                If tablo(i, j + 1) <> critere(1, j) Then copie = False: Exit For
            Next j
            If copie Then
                n = n + 1
                resu(n, 1) = tablo(i, 1)
                For j = 1 To ub: resu(n, j + 1) = critere(1, j): Next j
                resu(n, ub + 2) = tablo(i, ub + 2)
                resu(n, ub + 3) = w.Name
            End If
        Next i
    End If
Next w
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A7] '1ère cellule de validation, à adapter
    Intersect(.CurrentRegion, Rows(.Row).Resize(Rows.Count - .Row + 1)).ClearContents 'RAZ
    If n Then .Resize(n, ub + 3) = resu
End With
With UsedRange: End With 'ajuste les barres de défilement
End Sub

Elle se déclenche quand on active la feuille.

Elle est très rapide car on utilise des tableaux VBA et que la restitution se fait en bloc.

Je pense que Feuil3 était erronée, je l'ai corrigée et le résultat est bien celui indiqué au post #1.

Bonjour sylvanu.

 

[chilo]

Bonsoir sylvanu, Job75

Je vous remercie tous les deux pour votre réponse,
Mais la méthode de Sylvanu répond tout à fait à ce que je souhaite car je trouve dans mes
tableurs des nombres dans le désordre

Toutefois, le dernier de Job5 est très rapide
encore une fois merci pour l'aide apportée

 

[job75]

Alors si les chiffres à rechercher peuvent être dans le désordre ce n'est guère plus difficile.

Mais toujours pour aller vite il faut les lister dans un Dictionary, voyez ce fichier (2) et la macro :

Private Sub Worksheet_Activate()
Dim critere, ub%, d As Object, e, resu(), w As Worksheet, tablo, i&, copie As Boolean, j%, n&
critere = Feuil1.[B4:F4] 'vecteur ligne, plus rapide
ub = UBound(critere, 2)
Set d = CreateObject("Scripting.Dictionary")
'---liste des éléments de critère sans doublon---
For Each e In critere: d(e) = "": Next e
'---tableau des résultats---
ReDim resu(1 To Rows.Count, 1 To ub + 3)
For Each w In Worksheets
    If w.Name <> Me.Name Then
        tablo = w.Range("A6").CurrentRegion.Resize(, ub + 2) 'matrice, plus rapide
        For i = 1 To UBound(tablo)
            copie = True
            For j = 1 To ub
                If Not d.exists(tablo(i, j + 1)) Then copie = False: Exit For
            Next j
            If copie Then
                n = n + 1
                For j = 1 To ub + 2: resu(n, j) = tablo(i, j): Next j
                resu(n, ub + 3) = w.Name
            End If
        Next i
    End If
Next w
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A7] '1ère cellule de validation, à adapter
    Intersect(.CurrentRegion, Rows(.Row).Resize(Rows.Count - .Row + 1)).ClearContents 'RAZ
    If n Then .Resize(n, ub + 3) = resu
End With
With UsedRange: End With 'ajuste les barres de défilement
End Sub

J'ai remis Feuil3 avec B19:F19 comme c'était au départ.

 

[chilo]

BONSOIR LE FORUM

je l'ai essayé cela fonctionne, mais le soucis le nom des feuille

Alors si les chiffres à rechercher peuvent être dans le désordre ce n'est guère plus difficile.

Mais toujours pour aller vite il faut les lister dans un Dictionary, voyez ce fichier (2) et la macro :

Private Sub Worksheet_Activate()
Dim critere, ub%, d As Object, e, resu(), w As Worksheet, tablo, i&, copie As Boolean, j%, n&
critere = Feuil1.[B4:F4] 'vecteur ligne, plus rapide
ub = UBound(critere, 2)
Set d = CreateObject("Scripting.Dictionary")
'---liste des éléments de critère sans doublon---
For Each e In critere: d(e) = "": Next e
'---tableau des résultats---
ReDim resu(1 To Rows.Count, 1 To ub + 3)
For Each w In Worksheets
    If w.Name <> Me.Name Then
        tablo = w.Range("A6").CurrentRegion.Resize(, ub + 2) 'matrice, plus rapide
        For i = 1 To UBound(tablo)
            copie = True
            For j = 1 To ub
                If Not d.exists(tablo(i, j + 1)) Then copie = False: Exit For
            Next j
            If copie Then
                n = n + 1
                For j = 1 To ub + 2: resu(n, j) = tablo(i, j): Next j
                resu(n, ub + 3) = w.Name
            End If
        Next i
    End If
Next w
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A7] '1ère cellule de validation, à adapter
    Intersect(.CurrentRegion, Rows(.Row).Resize(Rows.Count - .Row + 1)).ClearContents 'RAZ
    If n Then .Resize(n, ub + 3) = resu
End With
With UsedRange: End With 'ajuste les barres de défilement
End Sub

J'ai remis Feuil3 avec B19:F19 comme c'était au départ.

bonsoir job j'allais répondre MERCI pour la modification

 

[chilo]

Bonjour le forum

POur compléter la chose

Est il possible de compter le nombre de fois
que 1 2 3 4 5 est compris dans la recherche

Merci de bien vouloir jeter un oeil ( et le récupérer bien sûr après)
Merci beaucoup de votre

 

[job75]

Bonjour chilo, le forum,

Est il possible de compter le nombre de fois
que 1 2 3 4 5 est compris dans la recherche

Voyez ce fichier (3) avec les comptages dans l'ordre et dans le désordre :

Private Sub Worksheet_Activate()
Dim critere, ub%, d As Object, e, resu(), w As Worksheet, tablo, i&, copie As Boolean, j%, n&, nn&
critere = Feuil1.[B4:F4] 'vecteur ligne, plus rapide
ub = UBound(critere, 2)
Set d = CreateObject("Scripting.Dictionary")
'---liste des éléments de critère sans doublon---
For Each e In critere: d(e) = "": Next e
'---tableau des résultats---
ReDim resu(1 To Rows.Count, 1 To ub + 4)
For Each w In Worksheets
    If w.Name <> Me.Name Then
        tablo = w.Range("A6").CurrentRegion.Resize(, ub + 2) 'matrice, plus rapide
        For i = 1 To UBound(tablo)
            copie = True
            For j = 1 To ub
                If Not d.exists(tablo(i, j + 1)) Then copie = False: Exit For
            Next j
            If copie Then
                n = n + 1 'comptage global
                resu(n, 1) = tablo(i, 1)
                For j = 1 To ub
                    resu(n, j + 1) = tablo(i, j + 1)
                    If resu(n, j + 1) <> critere(1, j) Then copie = False
                Next j
                If copie Then nn = nn + 1 'comptage dans l'ordre
                resu(n, ub + 2) = tablo(i, ub + 2)
                resu(n, ub + 3) = w.Name
                resu(n, ub + 4) = "dans " & IIf(copie, "l'ordre", "le désordre")
            End If
        Next i
    End If
Next w
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A7] '1ère cellule de validation, à adapter
    Intersect(.CurrentRegion, Rows(.Row).Resize(Rows.Count - .Row + 1)).ClearContents 'RAZ
    If n Then .Resize(n, ub + 4) = resu
End With
With UsedRange: End With 'ajuste les barres de défilement
Application.ScreenUpdating = True
MsgBox n & " ligne(s) trouvée(s) dont " & nn & " dans l'ordre et " & n - nn & " dans le désordre", vbInformation, "Recherche"
End Sub

Bonne journée.

 

[chilo]

Bonjour chilo, le forum,

Voyez ce fichier (3) avec les comptages dans l'ordre et dans le désordre :

Private Sub Worksheet_Activate()
Dim critere, ub%, d As Object, e, resu(), w As Worksheet, tablo, i&, copie As Boolean, j%, n&, nn&
critere = Feuil1.[B4:F4] 'vecteur ligne, plus rapide
ub = UBound(critere, 2)
Set d = CreateObject("Scripting.Dictionary")
'---liste des éléments de critère sans doublon---
For Each e In critere: d(e) = "": Next e
'---tableau des résultats---
ReDim resu(1 To Rows.Count, 1 To ub + 4)
For Each w In Worksheets
    If w.Name <> Me.Name Then
        tablo = w.Range("A6").CurrentRegion.Resize(, ub + 2) 'matrice, plus rapide
        For i = 1 To UBound(tablo)
            copie = True
            For j = 1 To ub
                If Not d.exists(tablo(i, j + 1)) Then copie = False: Exit For
            Next j
            If copie Then
                n = n + 1 'comptage global
                resu(n, 1) = tablo(i, 1)
                For j = 1 To ub
                    resu(n, j + 1) = tablo(i, j + 1)
                    If resu(n, j + 1) <> critere(1, j) Then copie = False
                Next j
                If copie Then nn = nn + 1 'comptage dans l'ordre
                resu(n, ub + 2) = tablo(i, ub + 2)
                resu(n, ub + 3) = w.Name
                resu(n, ub + 4) = "dans " & IIf(copie, "l'ordre", "le désordre")
            End If
        Next i
    End If
Next w
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A7] '1ère cellule de validation, à adapter
    Intersect(.CurrentRegion, Rows(.Row).Resize(Rows.Count - .Row + 1)).ClearContents 'RAZ
    If n Then .Resize(n, ub + 4) = resu
End With
With UsedRange: End With 'ajuste les barres de défilement
Application.ScreenUpdating = True
MsgBox n & " ligne(s) trouvée(s) dont " & nn & " dans l'ordre et " & n - nn & " dans le désordre", vbInformation, "Recherche"
End Sub

Bonne journée.

Merci Job75, pour l'aide cela me permet de gagner énormément de temps

Encore une fois merci pour l'aide apportée