VBA - Copier ligne avec condition ( recherche partielle)

**Kiwi1110** · 21/07/2016, 17h09

Bonjour le Forum,

Je tente de me former sur les bases de VBA, l'université ne dispensant aucun cours d'informatique !

Voilà mon problème,
Sur la première page j'ai une première colonne comportant deux grands types d'écritures, soit par exemple :

Bonfication Nom Prénom XX
Paiement Nom Prénom XX
Etc.
(XX réfère à des informations qui sont différentes et souvent incomplète comme l'adresse postale ou la date de transaction)
Cette colonne comporte environ 600 cases remplies.

J'ai une deuxième page; avec

C1    C2       C3                  C4            C5        C6             C7      C8
Nom   Prénom   Date de naissance   Nationalité   Adresse   Code postale   Ville   Pays

Pour environs 1000 personnes

Mon objectif est de créer un code qui identifie la personne (de la page 1), pour coller à coté de l'écriture de bonification ou paiement, la ligne d'information sur le client (présent sur la page deux)

Voici le bout de code que j'ai fait, mais sans grande réussite; je pense que la recherche n'est pas partielle.

Avec mes remerciements pour vos éclairages et conseils!
N'hésitez pas si vous aviez des questions si je ne suis pas clair.

Excellente soirée,
Elie

Problème actuel :
variable objet ou variable de bloc with non définie

Code :

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
Option Explicit
 
Sub Cherche()
'déclaration des variables :
Dim Valeur_Cherchee As String, Trouve As String
Dim i As Long
Dim J As Long
Dim K As Long
'********* à adapter ***********
'affectation de valeurs aux variables :
    'on cherche le mot ""
For J = 1 To 1000
Valeur_Cherchee = Feuil4.Cells(J, 1)
    'dans la première colonne de la feuille active
'Set PlageDeRecherche = ActiveSheet.Columns(2)
'*******************************
Feuil5.Activate
'méthode find, ici on cherche la valeur non exact (LookAt:=xlPart)k=Lignes
 
Trouve = Feuil5.Cells.Find(what:=Valeur_Cherchee, after:=ActiveCell, LookIn:= _
xlFormulas, lookat:=xlPart, searchorder:=xlByRows, searchdirection:= _
xlNext, MatchCase:=False, searchformat:=False).Activate
Selection.FindNext(after:=ActiveCell).Activate
K = ActiveCell.Row
 
For i = 1 To 10
Feuil4.Cells(J, i + 1) = Feuil5.Cells(K, i)
Next i
Next J
 
End Sub

**jeanmidudu** · 22/07/2016, 08h23

Bonjour,

Je pense qu'il va falloir que tu essayes d'être un peu plus claire dans tes explications, des images pouvant aider. Présente-nous ton document (s'il y a des infos confidentielles, met des valeurs bidon à la place), des captures d'écran de sa structure avec des flèches montrant ce que tu veux faire.

**Kiwi1110** · 22/07/2016, 09h30

Merci pour la réponse, voici les éclaircissements.
La première feuille, qui change tout les mois, comportant obligatoirement le nom
Nom : Feuille 1.PNG
Affichages : 624
Taille : 13,0 Ko

Nom : Feuille 1.PNG
Affichages : 624
Taille : 13,0 Ko

La seconde feuille; avec toute les informations nécessaire sur les clients
Nom : Feuille 2.PNG
Affichages : 559
Taille : 8,5 Ko

Enfin, le résultat que je souhaiterai atteindre ( Ou aussi sans la première colonne)
Nom : Resultat.PNG
Affichages : 674
Taille : 22,3 Ko

Je pensais faire une recherche partielle sur la première feuille, première case, et voir si dans la deuxième feuille, première colonne il y a une correspondance. Et faire jusqu'à un i defini
Puis coller la ligne correspondante à droite de la première feuille.

Habituellement je le faisait à la main, mais je pense qu'une macro sera plus rapide et efficace que moi ! Aujourd'hui je recommence de le faire marcher, je vous posterais mes avancées.

Merci et bonne journée

**jeanmidudu** · 22/07/2016, 11h09

C'est beaucoup plus clair comme ça, et je pense avoir une solution qui te convient :

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
 
Option Explicit
 
Sub test()
    Dim i As Long, j As Long, maxLig1 As Long, maxLig2 As Long, maxCol As Long, ligne As Long
    Dim rng1 As Range, rng2 As Range, search As Range, adr As Range
    Dim firstAddress
 
    maxLig1 = Feuil1.Range("A" & Rows.Count).End(xlUp).Row 'Récupère l'indice de la dernière ligne remplie de Feuil1
    maxLig2 = Feuil2.Range("A" & Rows.Count).End(xlUp).Row 'Idem pour Feuil2
 
    With Feuil2
        maxCol = .Range(.Cells(1, 1), .Cells(Rows.Count, Columns.Count)).Find("*", , , , xlByColumns, xlPrevious).Column
        Set rng2 = .Range(.Cells(1, 1), .Cells(maxLig2, maxCol))
    End With
 
    With Feuil1
        Set rng1 = .Range(.Cells(1, 1), .Cells(maxLig1, maxCol + 1))
    End With
 
    For i = 1 To maxLig2
        Set search = rng1.Find(rng2.Cells(i, 1).Value, , , xlPart, , , False)
        If Not search Is Nothing Then
            firstAddress = search.Address
            Do
                ligne = search.Row
                If InStr(rng1.Cells(ligne, 1).Value, rng2.Cells(i, 2).Value) Then
                    For j = 2 To maxCol + 1
                        rng1.Cells(ligne, j).Value = rng2.Cells(i, j - 1).Value
                    Next j
                End If
                Set search = rng1.FindNext(search)
            Loop While Not search Is Nothing And search.Address <> firstAddress
        End If
    Next i
End Sub

Edit : Si la solution te convient, merci de cliquer sur

et de plusser ma réponse

**Kiwi1110** · 22/07/2016, 12h00

Merci beaucoup !
Néanmoins certaines cellules n'ont pas de correspondance, malgré leurs présence dans la feuille deux.
Est-ce une histoire de majuscule, ou de placement dans la cellule, je ne sais pas. Je tente de me familiariser au code avant de me lancer dans des modifications !

Exemple de case ne marchant pas : ( Les noms et prénoms sont fictifs je précise)
Nom : 111.PNG
Affichages : 605
Taille : 9,3 Ko

Nom : 111.PNG
Affichages : 605
Taille : 9,3 Ko

**jeanmidudu** · 22/07/2016, 12h23

As-tu compris mon code (je m'excuse je ne l'ai pas commenté voilà en étant plus explicite) :

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
Option Explicit 'On oblige la déclaration des variables
 
Sub test()
    ''''''''''''''''Déclaration
    Dim i As Long, j As Long, maxLig1 As Long, maxLig2 As Long, maxCol As Long, ligne As Long
    Dim rng1 As Range, rng2 As Range, search As Range, adr As Range
    Dim firstAddress
 
    maxLig1 = Feuil1.Range("A" & Rows.Count).End(xlUp).Row 'Récupère l'indice de la dernière ligne remplie de Feuil1
    maxLig2 = Feuil2.Range("A" & Rows.Count).End(xlUp).Row 'Idem pour Feuil2
 
    With Feuil2
        maxCol = .Range(.Cells(1, 1), .Cells(Rows.Count, Columns.Count)).Find("*", , , , xlByColumns, xlPrevious).Column 'On compte le nombre max de colonnes à copier
        Set rng2 = .Range(.Cells(1, 1), .Cells(maxLig2, maxCol)) 'on met la plage des valeurs utilisées dans une variable (traitement plus rapide qu'un accès direct)
    End With
 
    With Feuil1
        Set rng1 = .Range(.Cells(1, 1), .Cells(maxLig1, maxCol + 1)) 'On met la plage qui va contenir les données (on 1 colonne de base et on va y ajouter toutes celles de la feuille d'où le maxCol+1
    End With
 
    For i = 1 To maxLig2 'Pour chaque ligne de la feuille 2
        Set search = rng1.Find(rng2.Cells(i, 1).Value, , , xlPart, , , False) 'On cherche dans la feuille 1 si le nom (nom de famille seulement) correspond
        If Not search Is Nothing Then 'Si au moins un résultat est trouvé
            firstAddress = search.Address 'On récupère l'adresse de la première occurence
            Do   'Faire
                ligne = search.Row 'On récupère la ligne de l'occurence
                If InStr(rng1.Cells(ligne, 1).Value, rng2.Cells(i, 2).Value) Then 'Si le prénom correspond également
                    For j = 2 To maxCol + 1 'On boucle sur les colonnes
                        rng1.Cells(ligne, j).Value = rng2.Cells(i, j - 1).Value 'Pour copier chaque donnée
                    Next j
                End If
                Set search = rng1.FindNext(search) 'On cherche la prochaine occurence
            Loop While Not search Is Nothing And search.Address <> firstAddress 'et on continue tant qu'il y a de nouvelles occurences
        End If
    Next i
End Sub

Je me rend compte que l'on peut peut-être encore améliorer.
Autrement, à part pour des données qui diffèrent (attention aux espaces en surplus et aux caractères invisible dans les noms/prénoms), je ne vois pas ce qui empêcherait de trouver l'occurrence. Voilà l'explication de l'utilisation de la méthode find dans ce cas :

Code :

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

1
2
3
4
5
 Set search = rng1.Find(rng2.Cells(i, 1).Value, , , xlPart, , , False)
'rng1 : plage de cellules dans laquelle on cherche
'rng2.cells(i,1).Value : valeur recherchée (correspond à la ième ligne de la première colonne de la feuille 2
'xlPart : recherche partielle (pas besoin que la cellule contienne uniquement la valeur cherchée, elle peut contenir en + d'autres choses
'False : Ici le false indique que la casse n'est pas respectée, donc pas de différence entre majuscules et minuscules

Si après avoir vérifié la bonne syntaxe ça ne fonctionne toujours pas, alors essaye de mettre un classeur avec des données qui ne fonctionnent pas.
Attention, je le redis, ce code vérifie individuellement le nom et le prénom. Il faut que les 2 soient trouvés.

voilà un code un peu (à peine) plus efficace (j'ai inhibé le calcul automatique et l'affichage pendant le traitement, on remet tout à jour à la fin) :

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
Option Explicit
 
Sub test()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    Dim i As Long, j As Long, maxLig1 As Long, maxLig2 As Long, maxCol As Long, ligne As Long
    Dim rng1 As Range, rng2 As Range, search As Range, adr As Range
    Dim firstAddress
 
    maxLig1 = Feuil1.Range("A" & Rows.Count).End(xlUp).Row 'Récupère l'indice de la dernière ligne remplie de Feuil1
    maxLig2 = Feuil2.Range("A" & Rows.Count).End(xlUp).Row 'Idem pour Feuil2
 
    With Feuil2
        maxCol = .Range(.Cells(1, 1), .Cells(Rows.Count, Columns.Count)).Find("*", , , , xlByColumns, xlPrevious).Column
        Set rng2 = .Range(.Cells(1, 1), .Cells(maxLig2, maxCol))
    End With
 
    With Feuil1
        Set rng1 = .Range(.Cells(1, 1), .Cells(maxLig1, maxCol + 1))
    End With
 
    For i = 1 To maxLig2
        Set search = rng1.Find(rng2.Cells(i, 1).Value, , , xlPart, , , False)
        If Not search Is Nothing Then
            firstAddress = search.Address
            Do
                ligne = search.Row
                If InStr(rng1.Cells(ligne, 1).Value, rng2.Cells(i, 2).Value) Then
                    For j = 2 To maxCol + 1
                        rng1.Cells(ligne, j).Value = rng2.Cells(i, j - 1).Value
                    Next j
                End If
                Set search = rng1.FindNext(search)
            Loop While Not search Is Nothing And search.Address <> firstAddress
        End If
    Next i
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

**jeanmidudu** · 22/07/2016, 13h34

Et voici en encore un peu plus rapide MAIS il faut faire attention à ce que l'ordre NOM puis Prénom dans chacune des 2 feuilles soit TOUJOURS respecté :

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
 
Option Explicit
 
Sub test()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    Dim i As Long, j As Long, maxLig1 As Long, maxLig2 As Long, maxCol As Long, ligne As Long
    Dim rng1 As Range, rng2 As Range, search As Range, adr As Range
    Dim firstAddress
 
    maxLig1 = Feuil1.Range("A" & Rows.Count).End(xlUp).Row 'Récupère l'indice de la dernière ligne remplie de Feuil1
    maxLig2 = Feuil2.Range("A" & Rows.Count).End(xlUp).Row 'Idem pour Feuil2
 
    With Feuil2
        maxCol = .Range(.Cells(1, 1), .Cells(Rows.Count, Columns.Count)).Find("*", , , , xlByColumns, xlPrevious).Column
        Set rng2 = .Range(.Cells(1, 1), .Cells(maxLig2, maxCol))
    End With
 
    With Feuil1
        Set rng1 = .Range(.Cells(1, 1), .Cells(maxLig1, maxCol + 1))
    End With
 
    For i = 1 To maxLig2
        Set search = rng1.Find(rng2.Cells(i, 1).Value & " " & rng.Cells(i, 2).Value, , , xlPart, , , False)
        If Not search Is Nothing Then
            firstAddress = search.Address
            Do
                ligne = search.Row
                For j = 2 To maxCol + 1
                    rng1.Cells(ligne, j).Value = rng2.Cells(i, j - 1).Value
                Next j
                Set search = rng1.FindNext(search)
            Loop While Not search Is Nothing And search.Address <> firstAddress
        End If
    Next i
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

**Kiwi1110** · 27/07/2016, 10h10

Merci infiniment !
Je ferme la discussion sur le sujet

VBA - Copier ligne avec condition ( recherche partielle) [XL-2016]

Macros et VBA Excel

Discussions similaires

Partager

Partager