Ajout de 2 lignes vides et encadrement valeurs identiques

[Michel566]

Bonjour !

Encore une demande d'aide et merci d'avance.

J'aimerais ajouter 2 lignes vides dans les feuilles Flexo, Sac et Sac compile pour les valeur identiques et encadrer les lignes de meme valeur dans une colonne spécifique lorsque les lignes sont ajoutés.

Je vous envois 2 fichiers. Flexo - Exemple, ou j'ai fais les modifications manuellement que j'aimerais avoir et mon fichiers original. De plus dans le fichier Exemple, j'ai mis une boite avec plus détail sur ma demande.

J'espere avoir été assez clair.

Merci !

 

[job75]

Re : Ajout de 2 lignes vides et encadrement valeurs identiques

Bonjour Michel566,

Ce que vous demandez est très lourd et à mon avis néfaste à une bonne présentation.

D'évidence vous n'êtes pas à l'aise avec les mises en forme, voyez le fichier joint :

- dans la feuille "Flexo" j'ai supprimé les MFC et créé un tableau Excel

- dans les feuilles "Sac" et "Sac Compile" j'ai ajouté la colonne "Numéro" (en dernier) et créé une MFC.

La colonne "Numéro" peut être masquée.

Par ailleurs j'ai revu la macro de la feuille "Flexo" :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 2 Or Target.Row < 3 Or Target(1) <> "OK" Then Exit Sub
With Sheets("Sac").Cells(Rows.Count, 1).End(xlUp)(2)
  .Resize(, 24).FormulaR1C1 = Target(1).EntireRow.FormulaR1C1 'colonnes A:X
  .Offset(, 24) = "=MAX(R2C:R[-1]C)+(RC6<>R[-1]C6)" 'numéro
End With
With Sheets("Sac Compile").Cells(Rows.Count, 1).End(xlUp)(2)
  .Resize(, 19).FormulaR1C1 = Target(1).EntireRow.FormulaR1C1 'colonnes A:S
  .Offset(, 19) = "=MAX(R2C:R[-1]C)+(RC6<>R[-1]C6)" 'numéro
End With
Target(1).EntireRow.Delete
'---tris colonnes F et C, largeur des colonnes---
With Sheets("Sac").[A1].CurrentRegion.Offset(2)
  .Sort .Columns("F"), xlAscending, .Columns("C"), , xlAscending, Header:=xlNo
  .EntireColumn.AutoFit
End With
With Sheets("Sac Compile").[A1].CurrentRegion.Offset(2)
  .Sort .Columns("F"), xlAscending, .Columns("C"), , xlAscending, Header:=xlNo
  .EntireColumn.AutoFit
End With
End Sub

Seules les formules ou valeurs sont transférées, pas les formats.

Edit : aïe le fichier s'était vérolé, je l'ai refait, j'espère que ça ne recommencera pas...

A+

 

[Michel566]

Re : Ajout de 2 lignes vides et encadrement valeurs identiques

Bonjour job75 !

Finalement j'ai eu la chance d'explorer ce que tu as fais et l'utilisation du tableau a réglée mon problème de copie de ligne avec formule d'une feuille à l'autre. Comme tu le mentionne, effectivement je n'ai pas beaucoup d'expérience avec l'utilisation de VBA. Pour faire suite à la solution que tu m'as envoyée, si je comprend bien, la colonne numéro sert à changer la couleur des ligne en bleu ou blanc. Par contre ce que j'aimerais c'est ajouter automatiquement 2 lignes vides si la valeur en colonne F est différente. Je m'explique si en colonne F de la ligne 3 j'ai 51 et en colonne F de la ligne 4 j'ai 52, j'aimerais que 2 lignes vide s'ajoute automatiquement entre ces 2 lignes. J'espère avoir été assez clair.

Je te remercie sincèrement pour ton aide !!

Bonne journée !

 

[job75]

Re : Ajout de 2 lignes vides et encadrement valeurs identiques

Bonjour Michel566,

Bis repetita :

Ce que vous demandez est très lourd et à mon avis néfaste à une bonne présentation.

Pour ne pas dire lourdingue

Et ici je ne parlais pas de VBA :

D'évidence vous n'êtes pas à l'aise avec les mises en forme (...)

A+

 

[job75]

Re : Ajout de 2 lignes vides et encadrement valeurs identiques

Re,

Puisque vous tenez à vos insertions de lignes :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 2 Or Target.Row < 3 Or Target(1) <> "OK" Then Exit Sub
Dim i&
With Sheets("Sac")
  i = .Cells(Rows.Count, 1).End(xlUp)(2).Row
  .Cells(i, 1).Resize(, 24).FormulaR1C1 = Target(1).EntireRow.FormulaR1C1 'colonnes A:X
  .Columns.AutoFit 'ajustement largeur
  With .Rows("3:" & i)
    .Sort .Columns("F"), xlAscending, .Columns("C"), , xlAscending, Header:=xlNo 'tri
    For i = .Rows.Count To 2 Step -1
      If .Cells(i, 6) > .Cells(i - 1, 6) Then .Rows(i).Resize(2).Insert
    Next
  End With
End With
With Sheets("Sac Compile")
  i = .Cells(Rows.Count, 1).End(xlUp)(2).Row
  .Cells(i, 1).Resize(, 19).FormulaR1C1 = Target(1).EntireRow.FormulaR1C1 'colonnes A:S
  .Columns.AutoFit 'ajustement largeur
  With .Rows("3:" & i)
    .Sort .Columns("F"), xlAscending, .Columns("C"), , xlAscending, Header:=xlNo 'tri
    For i = .Rows.Count To 2 Step -1
      If .Cells(i, 6) > .Cells(i - 1, 6) Then .Rows(i).Resize(2).Insert
    Next
  End With
End With
Target(1).EntireRow.Delete
End Sub

S'il n'y a pas trop de lignes ça ira assez vite.

De nouveau la coloration des lignes dans les 2 feuilles se fait par MFC.

Fichier (2).

J'espère que cette fois vous ne mettrez pas 15 jours pour donner vos commentaires...

A+

 

[job75]

Re : Ajout de 2 lignes vides et encadrement valeurs identiques

Bonjour Michel566, le forum,

Avec des tableaux VBA c'est très rapide même s'il y a beaucoup de lignes :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 2 Or Target.Row < 3 Or Target(1) <> "OK" Then Exit Sub
Transfert Target(1), Sheets("Sac"), 24 'colonnes A:X
Transfert Target(1), Sheets("Sac Compile"), 19 'colonnes A:S
Target(1).EntireRow.Delete
End Sub

Sub Transfert(Target As Range, feuille As Worksheet, ncol%)
Dim i&, t, rest(), j%, n&
With feuille
  On Error Resume Next: .ShowAllData: On Error GoTo 0 'si la feuille est filtrée
  i = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
  .Cells(i, 1).Resize(, ncol).FormulaR1C1 = Target.EntireRow.Resize(, ncol).FormulaR1C1
  .[A3].Resize(i, ncol).Sort .[F1], xlAscending, .[C1], , xlAscending, Header:=xlNo 'tri
  t = .[A1].CurrentRegion.Offset(2).Resize(, ncol).FormulaR1C1
  ReDim rest(1 To 3 * UBound(t), 1 To ncol)
  For j = 1 To ncol: rest(1, j) = t(1, j): Next '1ère ligne
  n = 1
  For i = 2 To UBound(t)
    n = n + 1
    If Val(t(i, 6)) > Val(t(i - 1, 6)) Then n = n + 2
    For j = 1 To ncol
      rest(n, j) = t(i, j)
  Next j, i
  .[A3].Resize(n, ncol) = rest
  .Columns.AutoFit 'ajustement largeur
End With
End Sub

Edit : .End(xlUp) sur colonne B car forcément il y a toujours des "OK".

Fichier joint.

Bonne journée.

 

[job75]

Re : Ajout de 2 lignes vides et encadrement valeurs identiques

Re,

Un complément utile avec ce fichier (2).

Quand le filtre automatique est en place (voir feuille "Sac") il est redimensionné :

Sub Transfert(Target As Range, feuille As Worksheet, ncol%)
Dim nlig, i&, t, rest(), j%, n&
nlig = 2 'nombre de lignes à intercaler, à adapter
With feuille
  On Error Resume Next: .ShowAllData: On Error GoTo 0 'si la feuille est filtrée
  i = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
  .Cells(i, 1).Resize(, ncol).FormulaR1C1 = Target.EntireRow.Resize(, ncol).FormulaR1C1
  .[A3].Resize(i, ncol).Sort .[F1], xlAscending, .[C1], , xlAscending, Header:=xlNo 'tri
  t = .[A1].CurrentRegion.Offset(2).Resize(, ncol).FormulaR1C1
  ReDim rest(1 To (nlig + 1) * UBound(t), 1 To ncol)
  For j = 1 To ncol: rest(1, j) = t(1, j): Next '1ère ligne
  n = 1
  For i = 2 To UBound(t)
    n = n + 1
    If Val(t(i, 6)) > Val(t(i - 1, 6)) Then n = n + nlig
    For j = 1 To ncol
      rest(n, j) = t(i, j)
  Next j, i
  .[A3].Resize(n, ncol) = rest
  .Columns.AutoFit 'ajustement de la largeur
  If .AutoFilterMode Then 'si le filtre automatique est en place
    .AutoFilterMode = False
    .[A2].Resize(n, ncol).AutoFilter 'redéfinit la plage du filtre
  End If
End With
End Sub

Edit : variante (2 bis) avec validation en colonne B de "OK sans filtre ou "OK avec filtre".

A+

 

[Michel566]

Re : Ajout de 2 lignes vides et encadrement valeurs identiques

Bonjour Job75 !

J'ai passé à travers ce que tu m'as envoyé, c'est fou, c'est exactement ce que je voulais et en plus ça m'a permis d'en apprendre
un plus. Mon niveau est passée de très nul à simplement nul, j'exagère un peu ...

Bref je te remercie énormément pour ton aide, c'est très apprécié.

Bonne journée !

 

[job75]

Re : Ajout de 2 lignes vides et encadrement valeurs identiques

Bonjour Michel566, le forum,

Heureux que tout cela vous convienne.

Juste une remarque, au lieu de :

On Error Resume Next: .ShowAllData: On Error GoTo 0 'si la feuille est filtrée

on peut utiliser plus simplement :

If .FilterMode Then .ShowAllData 'si la feuille est filtrée

qui fonctionne avec le filtre automatique ou le filtre avancé.

Edit : par ailleurs dans la version (2 bis) il vaut mieux placer :

.Columns.AutoFit 'ajustement largeur

après le filtrage pour que les flèches du filtre ne cachent pas les titres.

A bientôt.