Retrouver cellules
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
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 :
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).
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
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
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
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...
ok pedro merci du conseil, je débute, tout commentaire est bon à prendre
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 ?
@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
merci je vais essayer tout ça !
@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
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 ?
@Pedro
Et tes remarques sont très bien accueillis ^^
Merci d'avoir pris le temps de m'aider à me perfectionner ;D
RE PEDRO.
ca y est je viens de tester et oui ça marche nickel !
merci
@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.
du coup c'est la deuxième qui correspond à ce que je veux faire
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