Deux colonnes identiques sur deux feuilles même classeur

libellule85

XLDnaute Accro
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
 

Pièces jointes

  • Libellule85 essai 25 03 17.xlsm
    12.8 KB · Affichages: 28

job75

XLDnaute Barbatruc
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 :
Code:
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.
 

Pièces jointes

  • Libellule85 essai 25 03 17(1).xlsm
    29.1 KB · Affichages: 18
  • Libellule85 essai 25 03 17(1 bis).xlsm
    28.6 KB · Affichages: 20
Dernière édition:

job75

XLDnaute Barbatruc
Re,

Je suis parvenu à supprimer la 2ème boucle (imbriquée) en utilisant le Dictionary :
Code:
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+
 

Pièces jointes

  • Libellule85 essai 25 03 17(2).xlsm
    29.4 KB · Affichages: 22
Dernière édition:

Discussions similaires

Réponses
10
Affichages
500

Statistiques des forums

Discussions
312 932
Messages
2 093 730
Membres
105 802
dernier inscrit
Witchun