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

[Nicolas Lepauvre]

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.

 

[Nicolas Lepauvre]

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

Bonjour vgendron, 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.

 

[Nicolas Lepauvre]

S'il vous plait aidez moi, je suis à bout de souf...!

 

[job75]

Bonjour Nicolas, le forum,

Pour cette nouvelle demande il faut repérer les lignes de la liste initiale en Feuille1 (j'ai mis des numéros).

Ainsi elles ne seront pas considérées comme de nouvelles inscriptions.

Voici le code, en fait seule la 1ère macro a dû être modifiée :

Sub feuille1_vers_feuille2()
Dim P As Range, t, d As Object, i&, a, b, rest(), s
Set P = Tabelle2.[A1].CurrentRegion.Resize(, 3)
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)
Next
t = Tabelle1.[A1].CurrentRegion.Resize(, 6) 'matrice, plus rapide
For i = 2 To UBound(t)
  If d.exists(t(i, 1)) And t(i, 6) <> "" Or t(i, 6) = "" Then d(t(i, 1)) = t(i, 5) & Chr(1) & t(i, 4)
Next
If d.Count Then
  a = d.keys: b = d.items
  ReDim rest(UBound(a), 2) '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)
  Next
  '---restitution---
  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.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(UBound(a), 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
  '---restitution---
  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.Parent.Activate 'facultatif
End Sub

Je ne fais plus de tris, ce n'était de toute façon pas indispensable.

Fichier (5).

A+

 

[job75]

Bonjour Nicolas,

S'il vous plait aidez moi, je suis à bout de souf...!

J'espère que ça va mieux et que vous avez retrouvé votre souf...

Vous me paraissez être un curieux personnage : vous criez famine et quand on vous donne à manger, couic, inconnu au bataillon, silence radio.

A+

 

[Nicolas Lepauvre]

Bonjour Nicolas,

J'espère que ça va mieux et que vous avez retrouvé votre souf...

Vous me paraissez être un curieux personnage : vous criez famine et quand on vous donne à manger, couic, inconnu au bataillon, silence radio.

A+

Bonjour Job75, bonjour le forum.
En plus de mes soucis avec Excel s'y sont ajoutés des problèmes de santé. Avec la santé ça va mieux. Mais avec Excel pas.
Votre pemière reponse peut être facile à comprendre. Le fichier que vous m'avez posté est en attaché. Comment est il possible d'avoir le code de votre fichier sans le tri?
Merci

 

[job75]

Bonsoir Nicolas,

Utilisez les macros et le fichier (5) du post #18, c'est la seule solution avec votre dernière demande.

Et je ne fais plus de tri.

A+

 

[Nicolas Lepauvre]

Bonsoir Nicolas,

Utilisez les macros et le fichier (5) du post #18, c'est la seule solution avec votre dernière demande.

Et je ne fais plus de tri.

A+

Bonjour Job75, bonjour le forum
Merci pour votre réponse.
Une dernière prière. Pouvez-vous, s'il vous plait ajouter plus de commentaires sur votre code du fichier (5) du post #18?
Je n'y comprend rien. Par exemple: Que fait UBound? C'est quoi CreateObject("Scripting.Dictionary")? Que se passe t il avec a = d.keys: b = d.items? Et encore plus de questions...
Je tiens à vous rappeller que je débute en VBA.
Merci.

 

[job75]

Bonjour Nicolas,

Je ne vais pas vous faire un cours de VBA cher ami.

Je tiens à vous rappeller que je débute en VBA.

Vous pouvez progresser, en recherchant par exemple UBound ou Scripting.Dictionary sur le web.

A+

 

[Nicolas Lepauvre]

Bonjour Nicolas,

Je ne vais pas vous faire un cours de VBA cher ami.

Vous pouvez progresser, en recherchant par exemple UBound ou Scripting.Dictionary sur le web.

A+

Merci pour tout!

 

[Nicolas Lepauvre]

Merci à tous!

 

[Nicolas Lepauvre]

Bonjour Nicolas,

Je ne vais pas vous faire un cours de VBA cher ami.

Vous pouvez progresser, en recherchant par exemple UBound ou Scripting.Dictionary sur le web.

A+

Bonjour Job75
J’ai essayé d’ajouter une colonne supplémentaire sur la feuille 2. En modifiant votre code selon votre résonnement, il ne fonctionne plus. Pouvez-vous me dire ce qui est faux dans ma modification?
Merci.

 

[job75]

Bonjour Nicolas,

La bonne adaptation :

Sub feuille1_vers_feuille2()
Dim P As Range, t, d As Object, i&, a, b, rest(), s
Set P = Tabelle2.[A1].CurrentRegion.Resize(, 4)
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)
Next
t = Tabelle1.[A1].CurrentRegion.Resize(, 6) 'matrice, plus rapide
For i = 2 To UBound(t)
  If d.exists(t(i, 1)) And t(i, 6) <> "" Or t(i, 6) = "" Then d(t(i, 1)) = t(i, 5) & Chr(1) & t(i, 4) & Chr(1) & t(i, 3)
Next
If d.Count Then
  a = d.keys: b = d.items
  ReDim rest(UBound(a), 3) '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)
  Next
  '---restitution---
  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, 4) = rest
End If
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(, 4) '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(1) = t(i, 4): 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) & t(i, 4) & 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(UBound(a), 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
  '---restitution---
  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.Parent.Activate 'facultatif
End Sub

Fichier (6).

Edit 1 : il manquait un Chr(1) en 8ème ligne du code.

Edit 2 : par contre dans la 2ème macro il y avait un Chr(1) en trop après Else !

Edit3 : j'ai testé avec 9000 inscriptions nouvelles (sans doublon) en Feuille1.

Les macros s'exécutent alors en 0,35 et 0,45 seconde.

A+

 

[Nicolas Lepauvre]

Bonjour Nicolas,

La bonne adaptation :

Sub feuille1_vers_feuille2()
Dim P As Range, t, d As Object, i&, a, b, rest(), s
Set P = Tabelle2.[A1].CurrentRegion.Resize(, 4)
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) & t(i, 4)
Next
t = Tabelle1.[A1].CurrentRegion.Resize(, 6) 'matrice, plus rapide
For i = 2 To UBound(t)
  If d.exists(t(i, 1)) And t(i, 6) <> "" Or t(i, 6) = "" Then d(t(i, 1)) = t(i, 5) & Chr(1) & t(i, 4) & Chr(1) & t(i, 3)
Next
If d.Count Then
  a = d.keys: b = d.items
  ReDim rest(UBound(a), 3) '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)
  Next
  '---restitution---
  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, 4) = rest
End If
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(, 4) '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(1) = t(i, 4): 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, 4) & 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(UBound(a), 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
  '---restitution---
  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.Parent.Activate 'facultatif
End Sub

Fichier (6).

Edit : j'ai testé avec 9000 inscriptions nouvelles (sans doublon) en Feuille1.

Les macros s'exécutent alors en 0,35 et 0,45 seconde.

A+

 

[Nicolas Lepauvre]

Bonjour Nicolas,

La bonne adaptation :

Sub feuille1_vers_feuille2()
Dim P As Range, t, d As Object, i&, a, b, rest(), s
Set P = Tabelle2.[A1].CurrentRegion.Resize(, 4)
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) & t(i, 4)
Next
t = Tabelle1.[A1].CurrentRegion.Resize(, 6) 'matrice, plus rapide
For i = 2 To UBound(t)
  If d.exists(t(i, 1)) And t(i, 6) <> "" Or t(i, 6) = "" Then d(t(i, 1)) = t(i, 5) & Chr(1) & t(i, 4) & Chr(1) & t(i, 3)
Next
If d.Count Then
  a = d.keys: b = d.items
  ReDim rest(UBound(a), 3) '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)
  Next
  '---restitution---
  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, 4) = rest
End If
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(, 4) '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(1) = t(i, 4): 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, 4) & 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(UBound(a), 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
  '---restitution---
  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.Parent.Activate 'facultatif
End Sub

Fichier (6).

Edit : j'ai testé avec 9000 inscriptions nouvelles (sans doublon) en Feuille1.

Les macros s'exécutent alors en 0,35 et 0,45 seconde.

A+

Dans le cas où le tableau de la feuille 2 n'est pas une sous-partie directe du tableau de la feuille 1, le code ne fonctionne plus. Que peut-on y faire?
Merci

 

[job75]

Bonjour Nicolas,

Que peut-on y faire?

Ne pas faire n'importe quoi et adapter le code après avoir compris comment il fonctionne.

Persévérez, l'apprentissage du VBA prend du temps.

A+