Autres recherche sur plusieurs colonnes excel 2007

C

chilo

XLDnaute Occasionnel
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
 

Pièces jointes

  • Classeur3.zip
    13.4 KB · Affichages: 5
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Voyez le fichier joint et cette macro dans le code de la feuille "Récapitulation" :
VB: 
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.
 

Pièces jointes

  • Classeur(1).xlsm
    32.3 KB · Affichages: 7
Vote positif 0 Vote négatif
C

chilo

XLDnaute Occasionnel
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
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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 :
VB: 
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.
 

Pièces jointes

  • Classeur(2).xlsm
    33.1 KB · Affichages: 6
Vote positif 0 Vote négatif
C

chilo

XLDnaute Occasionnel
BONSOIR LE FORUM

je l'ai essayé cela fonctionne, mais le soucis le nom des feuille
job75 à dit:
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 :
VB: 
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.
Cliquez pour agrandir...
bonsoir job j'allais répondre MERCI pour la modification
 
Vote positif 0 Vote négatif
C

chilo

XLDnaute Occasionnel
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
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour chilo, le forum,
chilo à dit:
Est il possible de compter le nombre de fois
que 1 2 3 4 5 est compris dans la recherche
Cliquez pour agrandir...
Voyez ce fichier (3) avec les comptages dans l'ordre et dans le désordre :
Code: 
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.
 

Pièces jointes

  • Classeur(3).xlsm
    34.2 KB · Affichages: 13
Vote positif 0 Vote négatif
C

chilo

XLDnaute Occasionnel
job75 à dit:
Bonjour chilo, le forum,

Voyez ce fichier (3) avec les comptages dans l'ordre et dans le désordre :
Code: 
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.
Cliquez pour agrandir...
Merci Job75, pour l'aide cela me permet de gagner énormément de temps

Encore une fois merci pour l'aide apportée
 
Vote positif 0 Vote négatif

Discussions similaires

A
  • Résolu(e)
XL 2019 Filtre avancé avec critères et résultat dans une autre feuille (VBA)
Réponses
2
Affichages
131
Amilo
A
O
  • Résolu(e)
XL 2016 Transfert de données sous conditions
Réponses
4
Affichages
178
sylvanu
sylvanu
D
  • Résolu(e)
Microsoft 365 fonction de recherche multiple
Réponses
3
Affichages
224
dd_76
D
jeanmi
  • Question
XL 2010 supprimer les lignes en doubles dans un tableau
Réponses
4
Affichages
215
jeanmi
jeanmi
H
  • Question
Microsoft 365 faire une recherche a plusieurs condition
Réponses
8
Affichages
217
Honorine.bj
H
A
  • Question
XL 2019 Filtre avancé en VBA
Réponses
12
Affichages
302
Amilo
A
O
  • Question
Power Query Convertir un tableau de colonnes en lignes avec plusieurs variables (power query)
Réponses
8
Affichages
364
oobiz
O
R
  • Question
Microsoft 365 Formule excel
Réponses
4
Affichages
178
radia
R
C
  • Question
transposer lignes en colonnes
Réponses
1
Affichages
376
sousou
sousou
J
  • Question
XL 2019 Calculer une liste de distances avec l'adresse exacte en utilisant l'api Matrix Google
Réponses
3
Affichages
551
crocrocro
C

Membres actuellement en ligne

9 membres et 226 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 184
Messages
2 086 006
Membres
103 088
dernier inscrit
Psodam