VBA recherche, comparaison et déplacement de valeur

Version imprimable

12/03/2014, 17h04
BambaAmar

VBA recherche, comparaison et déplacement de valeur

Bonjour,

Je suis nouvellement inscrit et novice en VBA. Je cherche en fait à faire ceci : Prendre chaque valeur de la colonne A de la feuille une, aller la chercher sur la colonne A de la feuille deux. Si la macro trouve un résultat elle le déplace pour le mettre sur la même ligne de la colonne C de la feuille une. Sinon elle met un fond rouge.

Merci d'avance.

M le comptable fait du lettrage ou plutot du rapprochement !

Voici à coller dans un module:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub essai()
Dim cel As Variant
Dim CpT As String
Dim Cpp As Range
 
 
On Error Resume Next
'on boucle sur la colonne a feuil1
For Each cel In Worksheets("feuil1").Range("A2:A" & [A65000].End(xlUp).Row)
 
 
'recherche du nombre dans la colonne A
Set Cpp = Sheets("feuil2").Columns("A:A").Find(What:=cel, LookAt:=xlWhole)
 
'Si le nombre n'existe pas alors cellule C en couleur
If Cpp Is Nothing Then
 
  cel.Offset(0, 2).Interior.ColorIndex = 3
 
 
'Si le nombre existe on supprime la couleur et note le nombre!
Else
  cel.Offset(0, 2).Interior.ColorIndex = xlColorIndexNone
  cel.Offset(0, 2) = cel
End If
 
 
Next cel
 
 
End Sub

12/03/2014, 19h50
BambaAmar

Bien vu jijie. Il faut que ça aille plus vite pour faire du rapprochement.
Merci en tout cas pour la réponse. Je vais de ce pas le tester.

Citation:

Il faut que ça aille plus vite pour faire du rapprochement.

comment ça, c'est trop lent?

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Sub essai()
Dim cel As Variant
Dim CpT As String
Dim Cpp As Range
 
  Application.ScreenUpdating = False
 
On Error Resume Next
'on boucle sur la colonne a feuil1
For Each cel In Worksheets("feuil1").Range("A2:A" & [A65000].End(xlUp).Row)
 
 
'recherche du nombre dans la colonne A
Set Cpp = Sheets("feuil2").Columns("A:A").Find(What:=cel, LookAt:=xlWhole)
 
'Si le nombre n'existe pas alors cellule C en couleur
If Cpp Is Nothing Then
 
  cel.Offset(0, 2).Interior.ColorIndex = 3
 
 
'Si le nombre existe on supprime la couleur et note le nombre!
Else
  cel.Offset(0, 2).Interior.ColorIndex = xlColorIndexNone
  cel.Offset(0, 2) = cel
End If
 
 
Next cel
 
  Application.ScreenUpdating = true
 
End Sub

et là est-ce plus rapide!! tu as bcp de lignes !

12/03/2014, 21h36
BambaAmar

Non jijie, je me suis mal exprimé, ma phrase est bancale. Votre code marche nikel. Je voulais dire que sans macro le rapprochement prend trop de temps.
Mais pour que ça marche je veux carrément couper le résultat trouvé et le déplacer au lieu de le copier.

Merci encore le code est rapide et fonctionnel.

Citation:

Mais pour que ça marche je veux carrément couper le résultat trouvé et le déplacer au lieu de le copier.

alors :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Sub essai()
Dim cel As Variant
Dim CpT As String
Dim Cpp As Range
 
  Application.ScreenUpdating = False
 
On Error Resume Next
'on boucle sur la colonne a feuil1
For Each cel In Worksheets("feuil1").Range("A2:A" & [A65000].End(xlUp).Row)
 
 
'recherche du nombre dans la colonne A
Set Cpp = Sheets("feuil2").Columns("A:A").Find(What:=cel, LookAt:=xlWhole)
 
'Si le nombre n'existe pas alors cellule C en couleur
If Cpp Is Nothing Then
 
  cel.Offset(0, 2).Interior.ColorIndex = 3
 
 
'Si le nombre existe on supprime la couleur et note le nombre!
Else
  cel.Offset(0, 2).Interior.ColorIndex = xlColorIndexNone
  cel.Offset(0, 2) = cel
  Cpp.EntireRow.Delete
End If
 
 
Next cel
 
  Application.ScreenUpdating = True
 
End Sub

13/03/2014, 02h16
BambaAmar

Un mega merci à toi jijie. Ça fonctionne correctement. Je pense que je vais me lancer dans l'apprentissage de VBA.
Bonne nuit du coté de la France.

Bien cordialement.

Par contre si tu réalimente ta table de la feuille2 pour éviter de passer en rouge les opérations déjà raproché de la feuille1 il doit falloir :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Sub essai()
Dim cel As Variant
Dim CpT As String
Dim Cpp As Range
 
  Application.ScreenUpdating = False
 
On Error Resume Next
'on boucle sur la colonne a feuil1
For Each cel In Worksheets("feuil1").Range("A2:A" & [A65000].End(xlUp).Row)
 
 
'recherche du nombre dans la colonne A
Set Cpp = Sheets("feuil2").Columns("A:A").Find(What:=cel, LookAt:=xlWhole)
 
'Si le nombre n'existe pas alors cellule C en couleur
If Cpp Is Nothing Then
 
  if cel.Offset(0, 2)<>"" then cel.Offset(0, 2).Interior.ColorIndex = 3 'si la cellule C est vide alors en rouge
 
 
'Si le nombre existe on supprime la couleur et note le nombre!
Else
  cel.Offset(0, 2).Interior.ColorIndex = xlColorIndexNone
  cel.Offset(0, 2) = cel
  Cpp.EntireRow.Delete
End If
 
 
Next cel
 
  Application.ScreenUpdating = True
 
End Sub

a+ et merci de noter résolu!

13/03/2014, 15h16
BambaAmar

Tout y est. Merci pour la dernière astuce.

Bien cordialement