Deux colonnes identiques sur deux feuilles même classeur

[libellule85]

Bonsoir le forum,
Je pense que les VBAistes pourront m'aider.
Sur la feuille Bis les colonnes désignation et PU doivent être identiques que sur la feuille 1.
Si sur la feuille 1 je rajoute un article avec son PU et que je fais un trie le résultat doit être le même sur la Feuille Bis et si possible vice et versa.
D'avance je vous remercie pour votre aide

 

[job75]

Bonsoir libellule85,

C'est assez compliqué, et c'est lourd parce qu'il faut 2 boucles imbriquées.

Bien sûr j'utilise des tableaux VBA dans cette macro paramétrée :

Sub CopieFeuille(Fs As Worksheet, Fa As Worksheet)
'Fs feuille source, Fa feuille active
Dim Rs As Range, Ra As Range, ts, ta, ub&, t1(), t2(), i&, x$, j&, n&
Set Rs = Fs.Range("A6:D" & Application.Match("zzz", Fs.[A:A]))
Set Ra = Fa.Range("A6:D" & Application.Match("zzz", Fa.[A:A]))
If Rs.Row < 6 Then Set Rs = Fs.[A6:D6]
If Ra.Row < 6 Then Set Ra = Fa.[A6:D6]
ts = Rs: ta = Ra 'matrices, plus rapides
ub = UBound(ta)
ReDim t1(1 To Fa.Rows.Count, 1 To 1)
ReDim t2(1 To Fa.Rows.Count, 1 To 5)
'---remplissage de t1 et t2---
For i = 1 To UBound(ts)
  x = ts(i, 1) & Chr(1) & ts(i, 4)
  For j = 1 To ub
    If ta(j, 1) & Chr(1) & ta(j, 4) = x Then _
      If t1(j, 1) = "" Then t1(j, 1) = i: GoTo 1
  Next j
  n = n + 1 'nouvelle ligne
  t2(n, 1) = i: t2(n, 2) = ts(i, 1): t2(n, 5) = ts(i, 4)
1 Next i
'---restitutions---
Application.ScreenUpdating = False
Application.CutCopyMode = 0 'interdit le Copier-Coller
If Fa.FilterMode Then Fa.ShowAllData 'si la feuille est filtrée
Fa.Columns(1).Insert 'insertion colonne A auxiliaire
Ra.Columns(0) = t1 'restitution1
If n Then Ra(Ra.Rows.Count + 1, 0).Resize(n, 5) = t2 'restitution2
Set Ra = Ra(1, 0).Resize(Ra.Rows.Count + n, 8) 'redimensionne Ra
Ra.Sort Ra(1), xlAscending, Header:=xlNo 'tri sur la colonne auxiliaire
On Error Resume Next 'si aucune cellule vide
Ra.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Fa.Columns(1).Delete
With Fa.UsedRange: End With 'actualise la barre de défilement verticale
End Sub

La durée d'exécution augmente rapidement avec le nombre de lignes :

- 500 lignes => 0,31 seconde

- 1000 lignes => 0,89 seconde

- 2000 lignes => 3,2 secondes

- 4000 lignes => 12,7 secondes

- 8000 lignes => 50 secondes

- 16000 lignes => 201 secondes chez moi sur Win 10 - Excel 2013.

Fichier joint.

Edit : fichier (1 bis) avec un quadrillage noir par défaut, c'est quand même plus visible !

Et j'ai défusionné les cellules des titres, c'est plus facile pour trier ou filtrer.

Bonne nuit.

 

[libellule85]

Bonjour Job75, le forum,
Un très très grand merci, tu es formidable.
Bonne journée

 

[job75]

Bonjour libellule85, le forum,

Je viens de modifier la macro précédente :

- séparateur Chr(1) dans la concaténation par sécurité

- interdiction du Copier-Coller, à cause de .Insert.

Bonne journée.

 

[job75]

Re,

Je suis parvenu à supprimer la 2ème boucle (imbriquée) en utilisant le Dictionary :

Sub CopieFeuille(Fs As Worksheet, Fa As Worksheet)
'Fs feuille source, Fa feuille active
Dim Rs As Range, Ra As Range, ts, ta, ub&, t1(), t2(), d As Object, i&, x$, y$, p As Byte, n&
Set Rs = Fs.Range("A6:D" & Application.Match("zzz", Fs.[A:A]))
Set Ra = Fa.Range("A6:D" & Application.Match("zzz", Fa.[A:A]))
If Rs.Row < 6 Then Set Rs = Fs.[A6:D6]
If Ra.Row < 6 Then Set Ra = Fa.[A6:D6]
ts = Rs: ta = Ra 'matrices, plus rapides
ub = UBound(ta)
ReDim t1(1 To Fa.Rows.Count, 1 To 1)
ReDim t2(1 To Fa.Rows.Count, 1 To 5)
'---analyse de ta et des doublons---
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(ta)
  x = ta(i, 1) & Chr(1) & ta(i, 4)
  d(x) = d(x) & i & " "  'mémorisation des n° de lignes concaténés
Next
'---remplissage de t1 et t2---
For i = 1 To UBound(ts)
  x = ts(i, 1) & Chr(1) & ts(i, 4)
  y = d(x)
  If y <> "" Then
    p = InStr(y, " ") 'permer d'isoler le 1er n° de ligne
    t1(Left(y, p - 1), 1) = i
    d(x) = Mid(y, p + 1) 'le n° est retiré de la liste
    GoTo 1
  End If
  n = n + 1 'nouvelle ligne
  t2(n, 1) = i: t2(n, 2) = ts(i, 1): t2(n, 5) = ts(i, 4)
1 Next i
'---restitutions---
Application.ScreenUpdating = False
Application.CutCopyMode = 0 'interdit le Copier-Coller
If Fa.FilterMode Then Fa.ShowAllData 'si la feuille est filtrée
Fa.Columns(1).Insert 'insertion colonne A auxiliaire
Ra.Columns(0) = t1 'restitution1
If n Then Ra(Ra.Rows.Count + 1, 0).Resize(n, 5) = t2 'restitution2
Set Ra = Ra(1, 0).Resize(Ra.Rows.Count + n, 8) 'redimensionne Ra
Ra.Sort Ra(1), xlAscending, Header:=xlNo 'tri sur la colonne auxiliaire
On Error Resume Next 'si aucune cellule vide
Ra.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Fa.Columns(1).Delete
With Fa.UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Les durées d'exécution n'ont plus rien à voir avec les précédentes :

- 4000 lignes => 0,23 seconde

- 8000 lignes => 0,32 seconde

- 16000 lignes => 0,57 seconde

- 32000 lignes => 1,5 seconde

- 64000 lignes => 4,8 secondes

- 128000 lignes => 17 secondes.

Mon fichier de test était plein de doublons de lignes (8 lignes différentes seulement).

S'il n'y a pas de doublon c'est 5 secondes pour 128000 lignes.

Fichier (2).

A+

 

[libellule85]

Bonsoir Job75, le forum,
Job75 je te reconnais bien là, tu es la perfection incarnée !
Un grand grand merci pour ton aide

 

[job75]

Bonjour libellule85, le forum,

Oui perfectionniste, je viens de revoir la manière de traiter les d(x) du fichier (2).

Bonne journée.