Discussion :

[Bernard000]

Bonjour,

Malgré tous mes efforts et tous les forums consultés, je ne suis pas très doué en vba et je dois écrire une macro pour réaliser ce qui suit. J'espère que quelqu'un aura la gentillesse de m'aider à compléter mon code.

J’ai 2 fichiers :
-1 fichier base de données avec en colonne A des noms, en colonne B des prénoms et en colonne C des numéros de téléphone. (70 lignes)
-1 fichier exemple avec en colonne A des noms (29 lignes)

Je veux comparer les noms du fichier exemple avec ceux de la base de données. Si un nom du fichier exemple est déjà dans la base de données, je veux recopier les colonnes B et C correspondantes de la base de données dans le fichier exemple.

Voici le début de code que j'ai essayé d'écrire. Pourriez-vous m'aider à le terminer, svp ? Merci beaucoup

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub comp()
 
Dim f As Integer
Dim i As Integer
Dim valueref As Variant
Dim valuecomp As Variant
 
 
Workbooks("base_donnees.xls").Activate
 
For f = 2 To 70
Cells(f, 1).Activate
valueref = ActiveCell.Value
 
Workbooks("exemple.xls").Activate
For i = 2 To 39
valuecomp = ActiveCell.Offset(i, 0).Value
If valuecomp = valueref Then
 
???
End If
Next i
Next f

[NEC14]

Bonjour,

Avec un RechercheV en fonction d'Excel cela ne serait pas suffisant ?
Cordialement

[Bernard000]

Non, je dois le faire avec une macro.

[bboy-eazy]

Bonjour,

voici un code à adapter:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
35
36
37
38
39
40
41
42
43
44
45
46
47
Sub CompareReference()
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim RG2 As Range
Dim Cel As Range
Dim LastLine1 As Single
Dim LastLine2 As Single
Dim I As Single
 
Dim MyDico As Object
 
Set WB1 = Workbooks("classeur1")
Set WB2 = Workbooks("classeur2")
'Définit les deux classeurs
 
With WB2.Worksheets("nomdefeuille")
     LastLine2 = .Columns(1).Find("*", , , , xlByRows, xlPrevious).Row
     'Calcul de la dernière ligne
     Set RG2 = .Range(.Cells(3, 1), .Cells(LastLine2, 1))
End With
'Définit la plage de référence du classeur 2
 
Set MyDico = CreateObject("Scripting.Dictionary")
'Création du dictionnaire
 
For Each Cel In RG2
     If MyDico.Exists(CStr(Cel.Value)) = False And Cel.Value <> "" Then
          MyDico.Add CStr(Cel.Value), Cel.Value
     End If
Next Cel
'Remplis le dico avec les référence du classeur 2
 
With WB1.Worksheets("nomdefeuille")
    LastLine1 = .Columns(1).Find("*", , , , xlByRows, xlPrevious).Row
    'Calcul de la dernière ligne
    For I = LastLine1 To 1 Step -1
         If MyDico.Exists(CStr(.Cells(I, 1).Value)) = True ' mettre false pour tester si valeur non présente  
Then
 'que faire si la valeur est présente dans le dico
   Next I
End With
'On parcours les lignes une par une en commençant par la dernière.
'On regarde dans le Dico si les valeurs existent. Si elles existent, procédure à suivre 
Set MyDico = Nothing
'On Libère la variable
 
End Sub

[Invité]

Bonjour,

Une autre solution possible. Attention aux homonymies si vous ne testez que les noms !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
35
36
37
38
39
40
41
42
 
Sub Comparer()
 
 
Dim AireDonnees As Range
Dim AireExemple As Range
Dim CelluleExemple As Range
Dim CelluleDonnees As Range
 
 
Dim PremiereLigneDonnees As Long
Dim DerniereLigneDonnees As Long
Dim PremiereLigneExemple As Long
Dim DerniereLigneExemple As Long
 
 
 With Workbooks("Base de données.xlsm").Sheets("Annuaire")  ' A adapter
        PremiereLigneDonnees = 2
        DerniereLigneDonnees = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set AireDonnees = .Range(.Cells(PremiereLigneDonnees, 1), .Cells(DerniereLigneDonnees, 1))
 
 End With
 
 With Workbooks("Exemple.xlsm").Sheets("Exemple")  ' A adapter
        PremiereLigneExemple = 2
        DerniereLigneExemple = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set AireExemple = .Range(.Cells(PremiereLigneExemple, 1), .Cells(DerniereLigneExemple, 1))
 End With
 
 For Each CelluleExemple In AireExemple
     For Each CelluleDonnees In AireDonnees
 
        If CelluleExemple = CelluleDonnees Then
            CelluleExemple.Offset(0, 1) = CelluleDonnees.Offset(0, 1)
            CelluleExemple.Offset(0, 2) = CelluleDonnees.Offset(0, 2)
            Exit For
        End If
     Next CelluleDonnees
 Next CelluleExemple
 
 
End Sub

Cordialement.

[Thautheme]

Bonjour le fil, bonjour le forum,

Malgré le retard, je poste quand même une autre solution :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub comp()
Dim CB As Workbook 'déclare la variable CB (Classeur Base)
Dim CE As Workbook 'déclare la variable CE (Classeur Exemple)
Dim OB As Object 'déclare la variable OB (Onglet Base)
Dim OE As Object 'déclare la variable OE (Onglet Exemple)
Dim I As Integer 'déclare la variable I (Incrément)
Dim R As Range 'déclare la variable R (Recherche)
Dim ValueRef As String 'déclare la variable ValueRef
 
Set CB = Workbooks("base_donnees.xls") 'définit le classeur CB
Set CE = Workbooks("exemple.xls") 'définit le classeur CE
Set OB = CB.Sheets(1) 'définit l'onglet OB (à adapter)
Set OE = CE.Sheets(1) 'définit l'onglet OE (à adapter)
For I = 2 To 29 'boucle 1 : sur les 29 lignes du classeur exemple
    ValueRef = OE.Cells(I, 1) 'définit la variable ValueRef
    'définit la recherche R (recherche la valeur entière de ValueRef dans la colonne 1 (=A) dans l'onglet OB)
    Set R = OB.Columns(1).Find(valuref, , xlValues, xlWhole)
    If Not R Is Nothing Then 'condition : si il existe au moins une occurrence trouvée
        For J = 1 To 2 'boucle 2 : sur deux colonnes
            OE.Cells(I, J + 1) = R.Offset(0, J).Value 'récupère prénom et numéro de téléphone de la première occurrence trouvée
        Next J 'prochaine colonne de la boucle 2
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle 1
End Sub