Macro pour modifier automatiquement des éléments sur deux feuilles différentes

Nicolas Lepauvre

XLDnaute Junior
Bonjour à tous !
Je souhaite faire la chose suivante.
Si on effectue une modification dans l’une des colonnes B, C, D ou E de la feuille1, elle s‘actualise automatiquement sur la feuille2.
De même si on effectue une modification dans l’une des colonnes E ou D de la feuille2, elle devrait s‘actualiser automatiquement sur la feuille1. En plus si on fait une nouvelle inscription sur la feuille2 elle devrait apparaître sur la feuille1.
J’ai écrit un code dans un module mais il ne se passe rien.
De ce fait je sollicite vos aides précieuses.
Je vous remercie d’avance.
 

Pièces jointes

  • Feuil1_vs_Feuil2.xlsm
    20.7 KB · Affichages: 41

job75

XLDnaute Barbatruc
Bonjour Nicolas Lepauvre, vgendron, le forum,

Avec des tris c'est très rapide, voyez le fichier joint et ces macros :
Code:
Sub feuille1_vers_feuille2()
Dim P1 As Range, P2 As Range, rc&
Set P1 = Tabelle1.[A1].CurrentRegion
Set P2 = Tabelle2.[A1].CurrentRegion
If P2.Parent.FilterMode Then P2.Parent.ShowAllData 'si la feuille est filtrée
rc = P1.Rows.Count
If rc > 1 Then P2.Rows(2).Resize(rc - 1).Insert xlDown 'insertion de lignes
P2(1).Resize(rc) = P1.Columns(1).Value
P2(1, 3).Resize(rc) = P1.Columns(4).Value
P2(1, 2).Resize(rc) = P1.Columns(5).Value
P2.Sort P2(1), xlAscending, Header:=xlYes '1er tri sur colonne A
With P2.Offset(1).Columns(5)
  .Formula = "=1/(A1<>A2)"
  .Value = .Value 'supprime les formules
  .EntireRow.Resize(, 5).Sort .Cells, xlAscending, Header:=xlNo '2ème tri pour accélérer
  On Error Resume Next 'si aucune valeur d'erreur
  .SpecialCells(xlCellTypeConstants, 16).EntireRow.Resize(, 5).Delete xlUp
  .ClearContents
  With .Parent.UsedRange: End With 'actualise les barres de défilement
End With
P2.Parent.Activate 'facultatif
End Sub

Sub feuille2_vers_feuille1()
Dim P1 As Range, P2 As Range, rc&
Set P1 = Tabelle1.[A1].CurrentRegion
Set P2 = Tabelle2.[A1].CurrentRegion
If P1.Parent.FilterMode Then P1.Parent.ShowAllData 'si la feuille est filtrée
rc = P2.Rows.Count
If rc > 1 Then P1.Rows(2).Resize(rc - 1).Insert xlDown 'insertion de lignes
P1(1).Resize(rc) = P2.Columns(1).Value
P1(1, 5).Resize(rc) = P2.Columns(2).Value
P1(1, 4).Resize(rc) = P2.Columns(3).Value
P1.Sort P1(1), xlAscending, Header:=xlYes '1er tri sur colonne A
P1.Resize(, 3).Sort P1(1), xlAscending, P1(1, 2), , , P1(1, 3), Header:=xlYes '2ème tri sur 3 colonnes
With P1.Offset(1).Columns(7)
  .Formula = "=1/(A1<>A2)"
  .Value = .Value 'supprime les formules
  .EntireRow.Resize(, 7).Sort .Cells, xlAscending, Header:=xlNo '3ème tri pour accélérer
  On Error Resume Next 'si aucune valeur d'erreur
  .SpecialCells(xlCellTypeConstants, 16).EntireRow.Resize(, 7).Delete xlUp
  .ClearContents
  With .Parent.UsedRange: End With 'actualise les barres de défilement
End With
P1.Parent.Activate 'facultatif
End Sub
Il ne faut pas de doublons en colonne A : j'y ai ajouté une validation des données.

Voyez aussi les MFC pour les bordures et la couleur des titres.

Edit : ajouté le code pour le cas où la feuille de destination est filtrée.

A+
 

Pièces jointes

  • Feuil1_vs_Feuil2(1).xlsm
    30.3 KB · Affichages: 24
Dernière édition:

job75

XLDnaute Barbatruc
Re,

Je préfère cette solution avec le Dictionary car la conception est plus simple (pas de colonne auxiliaire) :
Code:
Sub feuille1_vers_feuille2()
Dim t, P As Range, rest(), d As Object, i&, a, b, s
t = Tabelle1.[A1].CurrentRegion.Resize(, 5) 'matrice, plus rapide
Set P = Tabelle2.[A1].CurrentRegion.Resize(, 3)
ReDim rest(UBound(t) + P.Rows.Count - 2, 2) 'base 0
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(t)
  d(t(i, 1)) = t(i, 5) & Chr(1) & t(i, 4)
Next
t = P 'matrice, plus rapide
For i = 2 To UBound(t)
  If Not d.exists(t(i, 1)) Then d(t(i, 1)) = t(i, 2) & Chr(1) & t(i, 3)
Next
If d.Count Then
  a = d.keys: b = d.items
  For i = 0 To UBound(a)
    rest(i, 0) = a(i)
    s = Split(b(i), Chr(1))
    rest(i, 1) = s(0): rest(i, 2) = s(1)
  Next
  '---restitition---
  If P.Parent.FilterMode Then P.Parent.ShowAllData 'si la feuille est filtrée
  If P.SpecialCells(xlCellTypeVisible).Count < P.Count Then _
    P.AutoFilter: P.AutoFilter 'défiltrage si tableau Excel
  P(2, 1).Resize(d.Count, 3) = rest
End If
P.CurrentRegion.Sort P(1), xlAscending, Header:=xlYes 'tri facultatif
P.Parent.Activate 'facultatif
End Sub

Sub feuille2_vers_feuille1()
Dim P As Range, t, d As Object, i&, s, a, b, rest()
Set P = Tabelle1.[A1].CurrentRegion.Resize(, 5)
t = P 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(t)
  d(t(i, 1)) = t(i, 2) & Chr(1) & t(i, 3) & Chr(1) & t(i, 4) & Chr(1) & t(i, 5)
Next
t = Tabelle2.[A1].CurrentRegion.Resize(, 3) 'matrice, plus rapide
For i = 2 To UBound(t)
  If d.exists(t(i, 1)) Then
    s = Split(d(t(i, 1)), Chr(1))
    s(2) = t(i, 3): s(3) = t(i, 2) 'remplacement
    d(t(i, 1)) = Join(s, Chr(1))
  Else
    d(t(i, 1)) = Chr(1) & Chr(1) & t(i, 3) & Chr(1) & t(i, 2)
  End If
Next
If d.Count Then
  a = d.keys: b = d.items
  ReDim rest(P.Rows.Count + UBound(t) - 2, 4) 'base 0
  For i = 0 To UBound(a)
    rest(i, 0) = a(i)
    s = Split(b(i), Chr(1))
    rest(i, 1) = s(0): rest(i, 2) = s(1): rest(i, 3) = s(2): rest(i, 4) = s(3)
  Next
  '---restitition---
  If P.Parent.FilterMode Then P.Parent.ShowAllData 'si la feuille est filtrée
  If P.SpecialCells(xlCellTypeVisible).Count < P.Count Then _
    P.AutoFilter: P.AutoFilter 'défiltrage si tableau Excel
  P(2, 1).Resize(d.Count, 5) = rest
End If
P.CurrentRegion.Sort P(1), xlAscending, Header:=xlYes 'tri facultatif
P.Parent.Activate 'facultatif
End Sub
Ces macros ne sont pas plus rapides que les précédentes : sur des tableaux de 100 000 lignes (sans doublons en colonne A) toutes les durées d'exécution sont chez moi entre 5 et 8 secondes.

Fichier (3).

A+
 

Pièces jointes

  • Feuil1_vs_Feuil2(3).xlsm
    34.2 KB · Affichages: 23

Nicolas Lepauvre

XLDnaute Junior
Hello
voir PJ avec macro dans les évènements change des deux feuilles.

Bonjour vgendron, bonjour le forum
J’ai encore un Problème.
Les nouvelles inscriptions faites sur la feuille 1 ne s’actualisent pas automatiquement sur la feuille 2. Et vice versa.
Pouvez-vous une fois de plus m’aider ?
Merci.
 

Pièces jointes

  • Feuil1_vs_Feuil2 Rev2.xlsm
    19.7 KB · Affichages: 17

Nicolas Lepauvre

XLDnaute Junior
Re,

Si pour tout automatiser vous voulez supprimer les boutons utilisez des Worksheet_Activate, fichier (4).

A+
Bonjour Job75 et merci.
Le problème avec votre code est qu'il y a autant d'inscription sur la feuille 1 que sur la feuille 2. Et cela ne doit pas être le cas. Le feuille 1 doit avoir plus d'inscriptions que la feuille 2. Et les éléments ne doivent pas être sur la même ligne.
Merci.
 

job75

XLDnaute Barbatruc
Bonjour Nicolas,
Le problème avec votre code est qu'il y a autant d'inscription sur la feuille 1 que sur la feuille 2. Et cela ne doit pas être le cas.
Pourtant quand vous dites :
Bonjour vgendron, bonjour le forum
J’ai encore un Problème.
Les nouvelles inscriptions faites sur la feuille 1 ne s’actualisent pas automatiquement sur la feuille 2. Et vice versa.
je comprends qu'il y a les mêmes inscriptions.

A+
 

Nicolas Lepauvre

XLDnaute Junior
Bonjour Nicolas,

Pourtant quand vous dites :

je comprends qu'il y a les mêmes inscriptions.

A+
Bonjour Job75, bonjour le forum
Encore plus de lumière sur mon problème.
Les inscriptions faites sur les feuilles 1 et 2 sont dites de « départ » avec x inscriptions sur la feuille 1 et y inscriptions sur la feuille 2. x étant supérieur à y. Dans ce cas on 30 inscriptions (x) sur la feuille 1 et 19 inscriptions (y) sur la feuille 2. Les entêtes n’étant pas comptées.
Les inscriptions de départ de la feuille 1 qui ne figurent pas sur la feuille 2 ne doivent pas s’y trouver.
Mais en revanche toute modification et nouvelle inscription faites sur la feuille 1 doivent s’actualiser automatiquement sur la feuille 2.
Et toute modification et nouvelle inscription faites sur la feuille 2 doivent s’actualiser automatiquement sur la feuille 1.
Je vous remercie pour votre attention et pour toute éventuelle aide.
 

Pièces jointes

  • Feuil1_vs_Feuil2 Rev2.xlsm
    19.7 KB · Affichages: 17

Statistiques des forums

Discussions
283 465
Messages
1 852 013
Membres
151 502
dernier inscrit
tyr
Haut Bas