Retrouver cellules

Le 13/09/2018 à 09:20

Bonjour à tous !

un petit problème à vous exposer. je veux retrouver des cellules identiques dans une autre feuille de calcul.

Ci-joint un tableau qui explique ce que je veux faire

merci d'avance pour vos solutions

19ex-forum.xlsx (11.74 Ko)
Le 13/09/2018 à 10:09

Bonjour Alex,

Voilà une macro te permettant de réaliser ce que tu souhaites :

Sub RetrouverSuite()

Dim Plage As Range, MaxLig As Long, MaxCol As Integer, Lig As Long, Col As Integer, NVal As Integer

'Sélection de la suite à chercher
Do
    Set Plage = Application.InputBox("Sélectionner la plage à tester", Type:=8)
    If Plage.Rows.Count > 1 Then MsgBox "Une ligne autorisée seulement !"
Loop While Plage.Rows.Count > 1

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Sheets("Feuil2")
    'Définition de la zone de recherche
    MaxLig = .Cells(Rows.Count, 1).End(xlUp).Row
    MaxCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    'Parcourir la zone de recherche
    For Lig = 1 To MaxLig
        For Col = 0 To MaxCol - 1
            'Parcourir la suite
            For NVal = 1 To Plage.Columns.Count
                'Si pas de correspondance pour un élément, on arrête de parcourir la suite
                If Not Plage(1, NVal) = .Cells(Lig, NVal + Col) Then Exit For
                'Si on est arrivé à la fin de la suite sans avoir interrompu la recherche, c'est qu'on a trouvé une correspondance exacte
                If NVal = Plage.Columns.Count Then GoTo Trouvé
            Next NVal
        Next Col
    Next Lig
End With

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Aucune correspondance trouvée"

Exit Sub

'En cas de correspondance
Trouvé:
With Sheets("Feuil2")
    For NVal = Plage.Columns.Count To 1 Step -1
        'Colorer en rouge les cellules
        .Cells(Lig, NVal + Col).Interior.ColorIndex = 3
    Next NVal
    'Sélectionner la première cellule retrouvée
    .Activate
    .Cells(Lig, Col + 1).Select
End With

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Correspondance trouvée"

End Sub

Le fichier correspondant :

12ex-forum.xlsm (22.87 Ko)

Ma proposition actuelle ne permet la sélection que d'une seule ligne à retrouver (mais pourrait être adaptée), et n'identifie que la première correspondance rencontrée en cas de correspondance multiple (= plusieurs endroit où la série est retrouvée).

Le 13/09/2018 à 11:02

Re Alex,

Re Pedro,

un petit problème à vous exposer.

Eh beh x) J'ai pas trouver sa simple à résoudre xDD

Ci-joint un fichier qui te permet de retrouver les lignes correspondantes dans une plage en Feuil2 et les mets en surbrillance quand le match est correct

Restant à dispo

9pour-alex-4.xlsm (24.76 Ko)
Le 13/09/2018 à 11:58

Re Juice,

J'ai procédé à une petite actualisation de mon code pour qu'il affiche toutes les correspondances d'une suite sélectionnée (toujours une suite d'une unique ligne) :

Sub RetrouverSuiteV2()

Dim Plage As Range, MaxLig As Long, MaxCol As Integer, Lig As Long, Col As Integer, NVal As Integer, Correspondance As Integer

'Sélection de la suite à chercher
Do
    Set Plage = Application.InputBox("Sélectionner la plage à tester", Type:=8)
    If Plage.Rows.Count > 1 Then MsgBox "Une ligne autorisée seulement !"
Loop While Plage.Rows.Count > 1

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Sheets("Feuil2")
    'Effacer remplissages précédents
    .Cells.Interior.ColorIndex = xlColorIndexNone
    'Définition de la zone de recherche
    MaxLig = .Cells(Rows.Count, 1).End(xlUp).Row
    MaxCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    'Parcourir la zone de recherche
    For Lig = 1 To MaxLig
        For Col = 0 To MaxCol - 1
            'Parcourir la suite
            For NVal = 1 To Plage.Columns.Count
                'Si pas de correspondance pour un élément, on arrête de parcourir la suite
                If Not Plage(1, NVal) = .Cells(Lig, NVal + Col) Then Exit For
                'Si on est arrivé à la fin de la suite sans avoir interrompu la recherche, c'est qu'on a trouvé une correspondance exacte
                If NVal = Plage.Columns.Count Then
                    Correspondance = Correspondance + 1
                    For NVal2 = 1 To Plage.Columns.Count
                        'Colorer en rouge les cellules
                        .Cells(Lig, NVal2 + Col).Interior.ColorIndex = 3
                    Next NVal2
                    'Continuer la recherche
                    If Col + NVal > MaxCol - 1 Then Col = MaxCol - 1 Else Col = Col + NVal
                    NVal = 1
                    Exit For
                End If
            Next NVal
        Next Col
    Next Lig
    .Activate
End With

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Correspondance = 0 Then MsgBox "Aucune correspondance trouvée" Else MsgBox Correspondance & " correspondance(s) trouvée(s)"

End Sub
Le 13/09/2018 à 12:09

juice,

je reviens sur mon ton programme de classement.

en fait sur un de mes tableau il me met un message d'erreur sur le programme , voici la ligne qui est surlignée erreur

k = Range("A" & v).End(xlToRight).Column

le programme complet le voici

Function CoulCel(Plage As Range) As Integer 'Création de la fonction couleur, permettant de donner une valeur

Application.Volatile ' à une cellule selon sa couleur

If Plage.Count > 1 Then Exit Function

CoulCel = Plage.Interior.ColorIndex

End Function

Sub Trie()

Dim x As Integer, y As Integer, k As Integer, Vérif As Integer, Limite As Integer, f As Integer, v As Integer

Dim Col As String, Col_2 As String

k = 101

v = 100

While k >= 100

k = Range("A" & v).End(xlToRight).Column

v = v - 1

Wend

Col = Split(Columns(k).Address(ColumnAbsolute:=False), ":")(1)

x = Range(Col & Rows.Count).End(xlUp).Row

f = Range(Col & "1").End(xlDown).Row - 1

If f + 1 <> x Then

While f <> 0

Rows(f).Select

Selection.Delete

f = f - 1

Wend

End If

x = Range(Col & Rows.Count).End(xlUp).Row

y = Range(Col & "1:" & Col & x).End(xlToRight).Column

Limite = y - k + 1

While x <> 0

Vérif = 0

y = Range(Col & "1:" & Col & x).End(xlToRight).Column

While y <> k

If Cells(x, y) >= 2 Then

Vérif = Limite + 1

End If

y = y - 1

Wend

y = Range(Col & "1:" & Col & x).End(xlToRight).Column

Col_2 = Split(Columns(y).Address(ColumnAbsolute:=False), ":")(1)

Range(Col & x & ":" & Col_2 & x).Select

If Vérif <= Limite Then

With Selection.Interior

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

.ThemeColor = xlThemeColorAccent1

.TintAndShade = 0.799981688894314

.PatternTintAndShade = 0

End With

Else

With Selection.Interior

.Pattern = xlNone

.TintAndShade = 0

.PatternTintAndShade = 0

End With

End If

x = x - 1

Wend

x = Range(Col & Rows.Count).End(xlUp).Row

While x <> 0

Cells(x, 3) = "=CoulCel(D" & x & ")"

If Cells(x, 3) <> 24 Then

Cells(x, 3) = ""

End If

x = x - 1

Wend

x = Range(Col & Rows.Count).End(xlUp).Row

y = Range(Col & "1:" & Col & x).End(xlToRight).Column

Col_2 = Split(Columns(y).Address(ColumnAbsolute:=False), ":")(1)

Col = Split(Columns(k - 1).Address(ColumnAbsolute:=False), ":")(1)

Columns(Col & ":" & Col_2).Select

ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear

ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("C1"), _

SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

With ActiveWorkbook.Worksheets("Feuil1").Sort

.SetRange Range(Col & "1:" & Col_2 & x)

.Header = xlNo

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

Columns(Col & ":" & Col).Select

Selection.ClearContents

'Col = Split(Columns(k).Address(ColumnAbsolute:=False), ":")(1)

'Range(Col & "1:" & Col_2 & x).Select

'With Selection.Interior

' .Pattern = xlNone

' .TintAndShade = 0

' .PatternTintAndShade = 0

'End With

Range("A1").Select

End Sub

Le 13/09/2018 à 12:11

Re Alex,

Il existe un bouton </> pour rendre lisible du code posté sur le forum, il ne faut pas s'en priver, surtout pour des macros avec un nombre de lignes conséquent...

Le 13/09/2018 à 12:17

ok pedro merci du conseil, je débute, tout commentaire est bon à prendre

Le 13/09/2018 à 12:19

Aussi, je me permet de faire quelques remarques sur ton code :

k = 101
v = 100

While k >= 100
   k = Range("A" & v).End(xlToRight).Column
   v = v - 1
Wend

Peut s'écrire :

v = 100
Do
   k = Range("A" & v).End(xlToRight).Column
   v = v - 1
Loop While k>= 100

Par ailleurs, que se passe-t-il si v devient inférieur à 1 ?

De plus :

Rows(f).Select
Selection.Delete

Équivaut à :

Rows(f).Delete

Aussi je vois beaucoup de boucles While...Wend avec des choses du genre x = x + 1. N'est ce pas plus simple d'utiliser des boucles For...Next ?

Le 13/09/2018 à 12:47

@Pedro

Quelque chose à redire sur le code que je lui ai précédemment fourni '^' ?

C'est une blague xDDD

Aussi, je me permet de faire quelques remarques sur ton code :

Code : Tout sélectionner

k = 101

v = 100

While k >= 100

k = Range("A" & v).End(xlToRight).Column

v = v - 1

Wend

Peut s'écrire :

Code : Tout sélectionner

v = 100

Do

k = Range("A" & v).End(xlToRight).Column

v = v - 1

Loop While k>= 100

Par ailleurs, que se passe-t-il si v devient inférieur à 1 ?

J'ai oublié de mettre dans la boucle un

If v <= 1 Then
Call Trie
End if

Qui permettrait de faire tourner cette première boucle a l'infini jusqu'à ce que la première ligne du tableau sois en ligne 1 du fichier excel

De plus :

Code : Tout sélectionner

Rows(f).Select

Selection.Delete

Équivaut à :

Code : Tout sélectionner

Rows(f).Delete

Sa c'est un détail qui ne ralentie pas l'exécution de la procédure x)

Aussi je vois beaucoup de boucles While...Wend avec des choses du genre x = x + 1. N'est ce pas plus simple d'utiliser des boucles For...Next ?

Pour ma part je préfère travailler avec les While et les Wend

Le 13/09/2018 à 13:02

merci je vais essayer tout ça !

Le 13/09/2018 à 13:07

@Alex

Puisque la ligne de code qui te sort une erreur est :

k = Range("A" & v).End(xlToRight).Column

C'est certainement la variable "v" (comme le dit Pedro) qui est la cause.

Alors modifie le code ci-dessous :

k = 101
v = 100

While k >= 100
   k = Range("A" & v).End(xlToRight).Column
   v = v - 1
Wend

Par :

v = 100 'Pedro
Do
   k = Range("A" & v).End(xlToRight).Column
   v = v - 1
Loop While k>= 100
Le 13/09/2018 à 14:10

Mes remarques ne sont que des questions de formes pour simplifier le code et le rendre plus lisible, mais j'ai testé par moi même, le code fonctionne parfaitement avec le fichier que tu as envoyé Juice !

Par ailleurs, Alex, as-tu testé mon code, et si oui, cela répond-t-il à ta demande ?

Le 13/09/2018 à 14:15

@Pedro

Et tes remarques sont très bien accueillis ^^

Merci d'avoir pris le temps de m'aider à me perfectionner ;D

Le 13/09/2018 à 14:28

RE PEDRO.

ca y est je viens de tester et oui ça marche nickel !

merci

Le 13/09/2018 à 14:41
Juice a écrit :

@Pedro

Et tes remarques sont très bien accueillis ^^

Merci d'avoir pris le temps de m'aider à me perfectionner ;D

J'ai regardé d'un peu plus près le code depuis ton fichier. Je dois être conditionné par les remarques des éminents contributeurs de ce forum par ce que la présence d'instructions "Select" me fait tiquer !

Voilà donc ton code modifié pour les supprimer, tout comme les boucles While...Wend qui alourdissent la lecture du code (mais cet avis n'engage que moi !).

En revanche, c'est la première fois que je vois ce genre d'instruction pour récupérer la lettre de colonne :

Split(Columns(1).Address(ColumnAbsolute:=False), ":")(1)

Mais je trouve ça astucieux et je le garde en mémoire. 

Sub rapprochement()
Dim lig As Integer, col As Integer                                          'var de feuil1
Dim lig2 As Integer, col2 As Integer                                        'var de feuil2
Dim k As Integer, x As Integer, p As Integer, v As Integer
Dim code As String, code2 As String
Dim Colonne As String, Colonne2 As String

col = Range("A1").End(xlToRight).Column
col2 = Sheets(2).Range("A1").End(xlToRight).Column

Sheets(1).Cells.Interior.ColorIndex = xlNone
Sheets(2).Cells.Interior.ColorIndex = xlNone

For lig = 1 To Range("A" & Rows.Count).End(xlUp).Row
    code = ""
    For k = 1 To col
        code = code & Cells(lig, k)
    Next k
    For lig2 = 1 To Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
        col = Range("A1").End(xlToRight).Column
        p = 1
        For x = 1 To col2 - col + 1
            code2 = ""
            For k = p To col
                code2 = code2 & Sheets(2).Cells(lig2, k)
            Next
            If code = code2 Then
                Colonne = Split(Columns(k - 10).Address(ColumnAbsolute:=False), ":")(1)
                Colonne2 = Split(Columns(k - 1).Address(ColumnAbsolute:=False), ":")(1)
                Sheets(2).Range(Colonne & lig2 & ":" & Colonne2 & lig2).Interior.Color = 65535
                v = Range("A1").End(xlToRight).Column
                Colonne = Split(Columns(1).Address(ColumnAbsolute:=False), ":")(1)
                Colonne2 = Split(Columns(v).Address(ColumnAbsolute:=False), ":")(1)
                Range(Colonne & lig & ":" & Colonne2 & lig).Interior.Color = 65535
            End If
            p = p + 1
            col = col + 1
        Next x
    Next lig2
Next lig

End Sub

@Alex, content de voir que ça répond à ta problématique. Je ne sais pas si tu as essayé la première version (s'arrête à la 1ère correspondance) ou la seconde (donne toutes les correspondances), ni laquelle correspond au mieux à ton besoin.

Le 13/09/2018 à 15:45

du coup c'est la deuxième qui correspond à ce que je veux faire

Le 13/09/2018 à 15:56

Si par "la deuxième" tu entend mon fichier tu peux utiliser le code que Pedro a mis juste au dessus

Sub rapprochement()
Dim lig As Integer, col As Integer                                          'var de feuil1
Dim lig2 As Integer, col2 As Integer                                        'var de feuil2
Dim k As Integer, x As Integer, p As Integer, v As Integer
Dim code As String, code2 As String
Dim Colonne As String, Colonne2 As String

col = Range("A1").End(xlToRight).Column
col2 = Sheets(2).Range("A1").End(xlToRight).Column

Sheets(1).Cells.Interior.ColorIndex = xlNone
Sheets(2).Cells.Interior.ColorIndex = xlNone

For lig = 1 To Range("A" & Rows.Count).End(xlUp).Row
    code = ""
    For k = 1 To col
        code = code & Cells(lig, k)
    Next k
    For lig2 = 1 To Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
        col = Range("A1").End(xlToRight).Column
        p = 1
        For x = 1 To col2 - col + 1
            code2 = ""
            For k = p To col
                code2 = code2 & Sheets(2).Cells(lig2, k)
            Next
            If code = code2 Then
                Colonne = Split(Columns(k - 10).Address(ColumnAbsolute:=False), ":")(1)
                Colonne2 = Split(Columns(k - 1).Address(ColumnAbsolute:=False), ":")(1)
                Sheets(2).Range(Colonne & lig2 & ":" & Colonne2 & lig2).Interior.Color = 65535
                v = Range("A1").End(xlToRight).Column
                Colonne = Split(Columns(1).Address(ColumnAbsolute:=False), ":")(1)
                Colonne2 = Split(Columns(v).Address(ColumnAbsolute:=False), ":")(1)
                Range(Colonne & lig & ":" & Colonne2 & lig).Interior.Color = 65535
            End If
            p = p + 1
            col = col + 1
        Next x
    Next lig2
Next lig

End Sub

C'est une version amélioré par Pedro (plus fluide et allégé) du code que je t'ai fais

Rechercher des sujets similaires à "retrouver"