Macro de comparaison d'une cellule d'une feuille avec une cellule d'une autre feuille.

Version imprimable

Bonjour à tous,

Voila je débute dans VBA (8 heures de cours intensifs), j’ai quelque notions mais pas de pratique.

J’ai un fichier .xls contenant 2 feuilles:

• Une première feuille « Tabelle1 » dite référence contenant plusieurs items uniques (environs 200), Colonnes de Réf “C2”.
• Une deuxième feuille « Tabelle2 » dite Data contenant plusieurs items (environs 30000) avec possibilité de doublons et beaucoup non présents dans la feuille de Référence (Tabelle 1), colonnes de Réf “E2”.

Les items dans "C2" et "E2" sont des valeurs numériques sur 5 digits.

Ce qui m’intéresse serait de faire une macro qui supprime toutes les lignes de la Feuil2 qui ne sont pas présents dans la Tabelle1. j'aimerais aussi conservé même les doublons qui sont présents dans la Tabelle1.

Si quelqu'un pouvait m'aider à réaliser cette macro, je suis preneur de toutes informations.

J’ai commencé par ceci mais je patine totalement :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 Sub Supprime_loop_non_reseau() Dim loop_Reseau As String Dim loop_Ref As String Dim Mycheck Dim Rng_Reseau As Range Dim Rng_Ref As Range Workbooks("testloop.xls").Sheets("Tabelle2").Activate Set Rng_Reseau = Range("c2").CurrentRegion Rng_Reseau.Value = loop_Reseau Workbooks("testloop.xls").Sheets("Tabelle1").Activate Set Rng_Ref = Range("e2") While ActiveCell.Value <> "" Mycheck = loop_Reseau Like loop_Ref Wend End Sub

Bonjour steelydan,

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
Dim i as Long, j as Byte
Dim Ws as WorkSheet
Dim Wc as WorkSheet
Dim RefTrouvee as Boolean
 
Set Ws = Workbooks("testloop.xls").Sheets("Tabelle2")
Set Wc = Workbooks("testloop.xls").Sheets("Tabelle1")
 
i = 1
Do While Ws.Range("E2").Cells(i, 1) <> ""
    j = 1
    RefTrouvee = False
    Do While Wc.Range("C2").Cells(j, 1) <> "" and RefTrouvee = False
        If Ws.Range("E2").Cells(i,1) = Wc.Range("C2").Cells(j, 1) Then
            RefTrouvee = True
        End If
        j = j + 1
    Loop
    If RefTrouvee = False Then
        Ws.Rows(i+1).Delete
    Else
        i = i + 1
    End If
Loop

Je n'ai pas testé le code car je n'ai pas tes données, mais dis moi si tu as une erreur et si ca fait ce que tu veux.

En gros, de ce que j'ai compris, si une référence de la feuille 2 est présente dans la feuille 1, on la garde, sinon on supprime la ligne dans la feuille 2.

07/09/2010, 17h10
steelydan

Salut Yoyo,

J'ai lancé la macro la premiere fois sur une copie du fichier cela a supprimé toute les lignes sur tabellle 2.

j'ai effectué une petite modif ensuite, en inversant partout le E2 par C2 et vice et versa.

Et la Nickel super tout fonctionne à merveille, t'es un crack.

Je te remercie enormément.

Pour infos pour environs 30000 lignes et 244 en Ref, cela a duré environs 10 min.
:ccool::ccool::ccool::ccool:

Je m'appelle karim j'ai omis de l'indiquer.

Merci encore.
07/09/2010, 17h29
Yoyo57
Salut Karim,

10 minutes c'est long... Je sais pas si tu dois refaire cà à l'avenir mais tu peux ajouter

Code:

Application.ScreenUpdating = False

au tout début de la macro pour gagner du temps d'exécution

A la fin de la macro, je te conseille un
Code:

1 2 Application.ScreenUpdating = True Call MsgBox("Opérations réalisées avec succès", vbOkOnly + vbInformation, "Traitement terminé")
Afin de savoir quand ton traitement est terminé.

Autre précision :

Si tu as moins de 32768 lignes à traiter, alors i peut être un entier au lieu d'un Long

Code:

Dim i as Integer

De plus, si tu dépasses 255 réfs dans ta feuille Tabelle1, alors j devra obligatoirement être un entier (sinon tu vas avoir une erreur à l'exécution) et non un Byte

Code:

Dim j as Integer

Un Byte ne peut dépasser 255 et un Integer ne peut dépasser 32768.

Ma proposition plus rapide

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub SupprAbs()
Dim LastLig1 As Long, LastLig2 As Long, i As Long
Dim c As Range
 
Application.ScreenUpdating = False
LastLig2 = Sheets("Tabelle2").Cells(Rows.Count, "C").End(xlUp).Row
If LastLig2 > 2 Then
    With Sheets("Tabelle1")
        LastLig1 = .Cells(Rows.Count, "E").End(xlUp).Row
        If LastLig1 > 2 Then
            For i = LastLig1 To 2 Step -1
                Set c = Sheets("Tabelle2").Range("C2:C" & LastLig2).Find(What:=.Range("E" & i).Value, LookIn:=xlValues, Lookat:=xlWhole)
                If c Is Nothing Then .Rows(i).Delete
            Next i
        End If
    End With
End If
End Sub

Pour les suppressions de lignes, il est plus facile de commencer du bas et remonter

Salut Lionel,

Nickel Lionel ,

Comme tu peux le voir ci-dessous petite inversion avec Tabelle1 et 2 , et champs E et C.

Après modifs elle s'execute en moins d'une minute, Tip Top !

Une petite question si ton temps te le permets comment pourrait-on traduire dans un langage simple la ligne de commande suivante, quelle est instruction qui fait la comparaison entre E et C :

Code:

Set c = Sheets("Tabelle1").Range("E2:E" & LastLig2).Find(What:=.Range("C" & i).Value, LookIn:=xlValues, Lookat:=xlWhole)
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 Sub SupprAbs() Dim LastLig1 As Long, LastLig2 As Long, i As Long Dim c As Range Application.ScreenUpdating = False LastLig1 = Sheets("Tabelle1").Cells(Rows.Count, "C").End(xlUp).Row If LastLig1 > 2 Then With Sheets("Tabelle2") LastLig2 = .Cells(Rows.Count, "E").End(xlUp).Row If LastLig2 > 2 Then For i = LastLig2 To 2 Step -1 Set c = Sheets("Tabelle1").Range("E2:E" & LastLig2).Find(What:=.Range("C" & i).Value, LookIn:=xlValues, Lookat:=xlWhole) If c Is Nothing Then .Rows(i).Delete Next i End If End With End If End Sub
Merci à toi Mercatog...
Je suis un peu perdu avec ces messages.
Merci en tous les cas Messieurs.

08/09/2010, 12h59
mercatog

Code:

Set c = Sheets("Feuil1").Range("E2:E100").Find(What:=Mot, LookIn:=xlValues, Lookat:=xlWhole)

Dans la plage E2:E100 de la feuille Feuil1 on cherche Mot.
Pour les paramètres lookin i lookat (il y en a d'autre) fait un F1 sur le mot find