Modification de code VBA pour synchroniser les cellules

Version imprimable

1 pièce(s) jointe(s)

Bonjour a tous suite a une aide que j'ai eu sur ce forum on a pue crée un code VBA permettant de récupérer les valeurs d'une feuille et de la transmettre a une autre feuille seulement si "le nom de la ligne" et identique.

Pour simplifier mon explication:

Si A1 dans feuille 1 et égale a A32 dans feuille 2 alors les données de la feuille 1 sont transmise sur la ligne 32 de la feuille 2.

Afin de simplifier mon classeur excel je souhaiterais que ce code synchronise les cellules a leur bon emplacement dans la feuille 2.

Par exemple dans la feuille 1 je souhaiterais que la cellule B45 soit envoyer sur la cellule BD8 de la feuille 2.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 Sub synctest() Dim F1 As Worksheet, F2 As Worksheet Dim DerLig_f2 As Long, i As Long Dim ID As String Dim x As Object Application.ScreenUpdating = False 'Evite les rafraîchissements de l'écran et augmente la vitesse d'exécution Set F1 = Sheets("Feuil1") 'on attribue la variable f1 à la feuille 1 Set F2 = Sheets("Feuil1") 'on attribue la variable f2 à la feuille 2 DerLig_f2 = F2.Range("B" & Rows.Count).End(xlUp).Row 'Dernière ligne de la feuille 2 DerCol_f2 = 17 'Dernière colonne de la feuille 2 For i = 11 To DerLig_f2 ' la variable i prend successivement la valeur de la ligne 11 à la dernière ligne de la feuille 2 ID = F2.Cells(i, "B") 'on récupère le code identificateur Set x = F1.Columns(11).Find(ID, LookIn:=xlValues, lookat:=xlWhole) 'on recherche l'ID dans la colonne 2 (la B) de la feuille 1 If Not x Is Nothing Then 'si x n'est pas rien alors: 'pour chaque ligne i testée, on copie la plage qui va de la colonne B à la dernière colonne de la feuille 2 destination feuille 1 colonne B F2.Range(F2.Cells(i, "C"), F2.Cells(i, DerCol_f2)).Copy Destination:=F1.Cells(x.Row, "L") End If Next i 'on passe à la valeur suivante de i End Sub
Un classeur exemple du résultat souhaité avec le code et des explication ;)
Pièce jointe 536133

Bonjour,

Je suppose que c'est une modification à apporter à la demande suivante:
https://www.developpez.net/forums/d2.../#post11321168

D'après ce que je crois comprendre (car vos explications ne sont pas franchement claires), on doit reporter les données de la feuille 1 vers la feuille 2 par rapport à un "code identifiant", sauf que les colonnes de la feuilles 2 sont dans un ordre totalement différent. Si c'est bien cela, reporter les données une à une prendrait un temps trop important (2500 lignes pour 23 colonnes). Je vous propose la solution suivante:
-Dans un premier temps, on récupère la liste des codes de la feuille 2(feuille destination) que l'on recopie en feuille 3 (feuille de calculs intermédiaires).
-Puis on recopie la ligne des entêtes de la feuille1 (feuille contenant la base de données) vers la feuille 3.
-On recopie chaque ligne de la feuille 1 vers la feuille 3 par recherche du code correspondant.
-Quand tout est recopié, on transfère colonne par colonne les données de la feuille 3 vers la feuille 2 par recherche de l'emplacement de la colonne correspondante.

Le fichier
Pièce jointe 536249

Le code utilisé

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
35
36
37
38
39
40
41
42
43
44
45
Sub Recup_Valeurs()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f2 As Long, i As Long, DerCol_f1 As Long
    Dim ID As String, Titre As String
    Dim x As Object, y As Object
 
    Application.ScreenUpdating = False 'Evite les rafraîchissements de l'écran et augmente la vitesse d'exécution
    Set f1 = Sheets("Feuil1") 'on attribue la variable f1 à la feuille 1
    Set f2 = Sheets("Feuil2") 'on attribue la variable f2 à la feuille 2
    Set f3 = Sheets("Feuil3") 'on attribue la variable f3 à la feuille 3
    DerLig_f2 = f2.Range("B" & Rows.Count).End(xlUp).Row 'Dernière ligne de la feuille 2
    DerCol_f1 = f2.Cells.Find("*", , , , xlByColumns, xlPrevious).Column  'Dernière ligne de la feuille 1
    'On fait une copie des codes (colonne B) de la feuille2 vers la feuille 3 (colonne B)
    f2.Columns(2).Copy f3.Columns(2)
    'on recopie la ligne des titres de la feuille 1 vers la feuille 3
    f1.Rows(10).Copy f3.Rows(10)
 
    'Rapatriement des données de la feuille 1 vers la feuille 3
    For i = 11 To DerLig_f2 ' la variable i prend successivement la valeur de la ligne 11 à la dernière ligne de la feuille 1
        ID = f1.Cells(i, "B")
        Set x = f3.Columns(2).Find(ID, LookIn:=xlValues, lookat:=xlWhole) 'on recherche l'ID dans la colonne 2 (la B) de la feuille 3
        If Not x Is Nothing Then 'si x n'est pas rien alors:
            'pour chaque ligne i testée, on copie la plage qui va de la colonne B à la dernière colonne de la feuille 1 destination feuille 3 colonne B
            f1.Range(f1.Cells(i, "B"), f1.Cells(i, DerCol_f1)).Copy Destination:=f3.Cells(x.Row, "B")
        End If
    Next i 'on passe à la valeur suivante de i
 
    'recopie des données dans la feuille 2
    f3.Select
    For i = 3 To DerCol_f1
        Titre = f3.Cells(10, i) 'on récupère l'entête de chaque colonne
        Set y = f2.Rows(10).Find(Titre, LookIn:=xlValues, lookat:=xlWhole) 'on recherche l'entête dans la ligne 10 de la feuille 2
        If Not y Is Nothing Then 'si y n'est pas rien alors:
        'on prend les colonnes (une par une) de la feuille 3 qu'on redistribue à leurs places respectives dans la feuille 2
            f3.Range(Cells(11, i), Cells(DerLig_f2, i)).Copy Destination:=f2.Cells(11, y.Column)
        End If
    Next i
    f3.Cells.ClearContents
    f2.Select 'affichage de la feuille 2
    Set x = Nothing
    Set y = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
    Set f3 = Nothing
End Sub

Si ce n'est pas ça, merci de bien décrire ce que ce que vous attendez.

Cdlt

06/02/2020, 08h08
wouairness

Bonjour ARTURO83 Merci pour ta réponse détaillé et rapide, je te confirme que tu as bien compris la thématique de mon problème mais seule un petit point que je n'es pas expliqué effectivement. Le code sera utiliser pour seulement quelle que ligne (environ 10) qui sera réutilisable en fonction de son utilisation.

Le but de mon classeur est le suivant: Géré la gestion de tout les poteaux incendie du secteur (66 communes) sur la premier feuille (le TGRI) toute les informations des poteaux son référencé et sur un seconde feuille j'ai la réception des tournées exécuté par des sous traitant a ma demande.
Par exemple je demande qu'il effectue une tourné de 12 Poteaux, qu'ils contrôlerons grâce a un formulaire en ligne d'ou la réception des informations son dans la deuxième feuille, vue que l'arrivé des informations ne sont pas dans l'ordre du "TGRI" je souhaiterais du coup un code capable de faire l'action d'écrite plus haut. ;)

Merci
06/02/2020, 08h30
ARTURO83

Je reformule votre demande:
-La base de données est dans la feuille 1
-Un tableau d'une dizaine de lignes que vous collez dans la feuille 2 vous est retournée et remplie par le sous-traitant.

A partir de là que doit-on faire?
-Mettre à jour le tableau de la feuille 1 avec les nouvelles données de la feuille 2?

Désolé de vous demander cela, mais vos explications sont confuses et j'ai beaucoup de mal à comprendre où vous voulez en venir.
Le plus simple, faites 2 fichiers excel avec quelques lignes, 1 avant et 1 après modifications. On gagneras du temps (fichiers excel exempt de toutes données confidentielles bien entendu)

1 pièce(s) jointe(s)

Bonjour
à tester
NB : si la plage de destination est vide et/ou vous voulez la remplacez par les nouvelles valeurs :

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 synctest()
    Dim F1 As Worksheet, F2 As Worksheet
    Dim DerLig_f2 As Long, i As Long
    Dim ID As String
    Dim x As Object
    Application.ScreenUpdating = False 'Evite les rafraîchissements de l'écran et augmente la vitesse d'exécution
    Set F1 = Sheets("Feuil1") 'on attribue la variable f1 à la feuille 1
    Set F2 = Sheets("Feuil2") 'on attribue la variable f2 à la feuille 2
    DerLig_f2 = F2.Range("B" & Rows.Count).End(xlUp).Row 'Dernière ligne de la feuille 2
    For i = 11 To DerLig_f2  ' la variable i prend successivement la valeur de la ligne 11 à la dernière ligne de la feuille 2
        ID = F2.Cells(i, "B") 'on récupère le code identificateur
        Set x = F1.Columns("B").Find(ID, LookIn:=xlValues, lookat:=xlWhole) 'on recherche l'ID dans la colonne 2 (la B) de la feuille 1
        If Not x Is Nothing Then 'si x n'est pas rien alors:
            'pour chaque ligne i testée, on copie la plage qui va de la colonne B à la dernière colonne de la feuille 2 destination feuille 1 colonne B
            F2.Cells(i, "D") = F1.Cells(x.Row, "G")
            F2.Cells(i, "E") = F1.Cells(x.Row, "H")
            F2.Cells(i, "F") = F1.Cells(x.Row, "E")
            F2.Cells(i, "G") = F1.Cells(x.Row, "F")
            F2.Cells(i, "H") = F1.Cells(x.Row, "D")
        End If
    Next i 'on passe à la valeur suivante de i
    Application.ScreenUpdating = True
End Sub

Si vous voulez garder les anciennes données en ajoutant les nouvelles valeurs : cas de ce banane que vous avez coloré en rouge

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 synctest()
    Dim F1 As Worksheet, F2 As Worksheet
    Dim DerLig_f2 As Long, i As Long
    Dim ID As String
    Dim x As Object
    Application.ScreenUpdating = False 'Evite les rafraîchissements de l'écran et augmente la vitesse d'exécution
    Set F1 = Sheets("Feuil1") 'on attribue la variable f1 à la feuille 1
    Set F2 = Sheets("Feuil2") 'on attribue la variable f2 à la feuille 2
    DerLig_f2 = F2.Range("B" & Rows.Count).End(xlUp).Row 'Dernière ligne de la feuille 2
    For i = 11 To DerLig_f2  ' la variable i prend successivement la valeur de la ligne 11 à la dernière ligne de la feuille 2
        ID = F2.Cells(i, "B") 'on récupère le code identificateur
        Set x = F1.Columns("B").Find(ID, LookIn:=xlValues, lookat:=xlWhole) 'on recherche l'ID dans la colonne 2 (la B) de la feuille 1
        If Not x Is Nothing Then 'si x n'est pas rien alors:
            'pour chaque ligne i testée, on copie la plage qui va de la colonne B à la dernière colonne de la feuille 2 destination feuille 1 colonne B
            F2.Cells(i, "D") = F2.Cells(i, "D") & "  " & F1.Cells(x.Row, "G")
            F2.Cells(i, "E") = F2.Cells(i, "E") & "  " & F1.Cells(x.Row, "H")
            F2.Cells(i, "F") = F2.Cells(i, "F") & "  " & F1.Cells(x.Row, "E")
            F2.Cells(i, "G") = F2.Cells(i, "G") & "  " & F1.Cells(x.Row, "F")
            F2.Cells(i, "H") = F2.Cells(i, "H") & "  " & F1.Cells(x.Row, "D")
        End If
    Next i 'on passe à la valeur suivante de i
    Application.ScreenUpdating = True
End Sub

Bonjour a tous;

Merci BENNASR pour ton code mais je n'arrive pas a l'appliquer sur mon doc officiel en suivant t'es instructions.

Pour plus de détail:

Ma Feuille Source s'appelle "form"
Ma Feuille de réception s'appelle "test"
Pour la feuille Source: Mon tableau commence en A1 (avec l’entête (A2 sans l’entête) et fini en illimité en fonction des réceptions des formulaires
Pour la feuille Source: Ma colonne ou ce trouve l'ID est en "H"
Pour la feuille Source: les données de la colonne "I" doivent être envoyer en colonne "K" sur "test"
Pour la feuille Réception: Mon tableau commence en B6 (avec l’entête (B13 sans l’entête) et fini
Pour la feuille Réception: Ma colonne ou ce trouve l'ID est en "H"

Pourrais tu me dire ou je me suis trompé dans ton code stp?
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 Sub synctest() Dim F1 As Worksheet, F2 As Worksheet Dim DerLig_f2 As Long, i As Long Dim ID As String Dim x As Object Application.ScreenUpdating = False 'Evite les rafraîchissements de l'écran et augmente la vitesse d'exécution Set F1 = Sheets("form") 'on attribue la variable f1 à la feuille 1 Set F2 = Sheets("test") 'on attribue la variable f2 à la feuille 2 DerLig_f2 = F2.Range("H" & Rows.Count).End(xlUp).Row 'Dernière ligne de la feuille 2 For i = 13 To DerLig_f2 ' la variable i prend successivement la valeur de la ligne 11 à la dernière ligne de la feuille 2 ID = F2.Cells(i, "H") 'on récupère le code identificateur Set x = F1.Columns("H").Find(ID, LookIn:=xlValues, lookat:=xlWhole) 'on recherche l'ID dans la colonne 2 (la B) de la feuille 1 If Not x Is Nothing Then 'si x n'est pas rien alors: 'pour chaque ligne i testée, on copie la plage qui va de la colonne B à la dernière colonne de la feuille 2 destination feuille 1 colonne B F2.Cells(i, "K") = F2.Cells(i, "K") & " " & F1.Cells(x.Row, "I") End If Next i 'on passe à la valeur suivante de i Application.ScreenUpdating = True End Sub

06/02/2020, 11h10
BENNASR

bonjour
je comprends pas ça :

Citation:

Pour la feuille Réception: Mon tableau commence en B6 (avec l’entête (B13 sans l’entête) et fini

pour aller directe au but , peux tu joindre un fichier test rassemble à ton fichier avec des données fictives

à tester (je vois âs de différence par rapport à ton code qui doit normalement fonctionné

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub synctest()
    Dim F1 As Worksheet, F2 As Worksheet
    Dim DerLig_f2 As Long, i As Long
    Dim ID As String
    Dim x As Object
    Application.ScreenUpdating = False 'Evite les rafraîchissements de l'écran et augmente la vitesse d'exécution
    Set F1 = Sheets("form") 'on attribue la variable f1 à la feuille 1
    Set F2 = Sheets("test") 'on attribue la variable f2 à la feuille 2
    DerLig_f2 = F2.Range("H" & Rows.Count).End(xlUp).Row 'Dernière ligne de la feuille 2
    For i = 13 To DerLig_f2  ' la variable i prend successivement la valeur de la ligne 11 à la dernière ligne de la feuille 2
        ID = F2.Cells(i, "H") 'on récupère le code identificateur
        Set x = F1.Columns("H").Find(ID, LookIn:=xlValues, lookat:=xlWhole) 'on recherche l'ID dans la colonne 2 (la B) de la feuille 1
        If Not x Is Nothing Then 'si x n'est pas rien alors:
            'pour chaque ligne i testée, on copie la plage qui va de la colonne B à la dernière colonne de la feuille 2 destination feuille 1 colonne B
           F2.Cells(i, "K") = F2.Cells(i, "K") & "  " & F1.Cells(x.Row, "I")
        End If
    Next i 'on passe à la valeur suivante de i
    Application.ScreenUpdating = True
End Sub

06/02/2020, 11h36
wouairness

C'est super, sa fonction je vais complètement le configurer pour mon dossier et je clôture ce forum par un "résolut" une fois fait. Merci beaucoup.
18/01/2021, 09h10
wouairness

Bonjour BENNASR et à vous tous;

Je me permets de revenir sur cette discussion afin de te demander si tu saurais comment transférer une cellule grace à ton code sauf si elle est vide (afin de garder les anciennes données si des nouvelles ne sont pas présentes).

Je pense que seul la partie:

Code:

F2.Cells(a, "O") = F1.Cells(x.Row, "C")

est a modifier.

Je te remercie par avance

Bonne journée :)
18/01/2021, 09h40
wouairness

Rebonjour,

En fin de compte j'ai réussit a me débrouiller.

Je place le bout de code pour toute personne qui cherche a faire de même. Je vous souhaite une bonne journée.

Code:

If F1.Cells(x.Row, "B") <> "" Then F2.Cells(a, "N") = F1.Cells(x.Row, "B")