Inserer ligne automatiquement avec condition

[BRUNO62]

Bonjour,

J'ai besoin d'aide, ci-joint la demande.
A partir de la colonne B pour les données ("D712", "D727"), je souhaiterais insérer automatiquement une ligne supplémentaire reprenant les données de celle-ci en incrémentant la colonne F de 6 mois. Le nombre de ligne de la colonne B n'est pas défini
Par avance, merci
A+

 

[Guest]

Re : Inserer ligne automatiquement avec condition

Bonsoir,

Encore un qui nous oblige à ouvrir un fichier pour savoir de quoi il retourne! Peuvent pas le dire dans leur Post? C'est trop dur?

A+

 

[job75]

Re : Inserer ligne automatiquement avec condition

Bonsoir BRUNO62,

Il s'agit d'une autre version des questions posées sur ce fil :

https://www.excel-downloads.com/threads/inserer-lignes-si-criteres-resolu.212249/

Alors utilisez cette macro :

Sub Insereligne()
Dim plage As Range, ncol%, code, c, cel As Range
Set plage = Range("B3:G" & [B3].End(xlDown).Row) 'à adapter
ncol = plage.Columns.Count
code = Array("D712", "D727") 'les codes à traiter
Application.ScreenUpdating = False
For Each c In code
  For Each cel In plage.Columns(1).Cells
    If cel = c Then
      cel(2).Resize(, ncol).Insert xlDown
      cel.Resize(, ncol).Copy cel(2)
      cel(2) = "µµµ" 'caractères provisoires
      cel(2, 5) = DateAdd("m", 6, cel(1, 5))
    End If
  Next
  plage.Columns(1).Replace "µµµ", c
Next
End Sub

Fichier (6) joint.

Edit : bonsoir Hasco, je ne t'avais pas vu.

A+

 

[BRUNO62]

Re : Inserer ligne automatiquement avec condition

Bonsoir job75,

C'est ok, encore merci
Si, cela est possible.
Pouvez vous me commenter la macro
Merci
A+

 

[job75]

Re : Inserer ligne automatiquement avec condition

Re,

Si le code recherché se trouve sur la dernière ligne du tableau, ma macro du post #3 ne va pas.

Il faut ajouter + 1 en 3ème ligne :

Set plage = Range("B3:G" & [B3].End(xlDown).Row + 1) 'à adapter

Fichier (7).

PS : si vous avez bien suivi (et compris) la discussion du lien (post #3) vous devez arriver à comprendre ma macro.

A+

 

[job75]

Re : Inserer ligne automatiquement avec condition

Bonjour BRUNO62, le forum,

Avec un index de ligne c'est mieux :

Sub Insereligne()
Dim P As Range, ncol%, code, c, i&
Set P = Range("B3:G" & [B3].End(xlDown).Row) 'à adapter
ncol = P.Columns.Count
code = Array("D712", "D727") 'les codes à traiter
Application.ScreenUpdating = False
For Each c In code
  For i = P.Rows.Count To 1 Step -1
    If P(i, 1) = c Then
      P(i + 1, 1).Resize(, ncol).Insert xlDown
      P(i, 1).Resize(, ncol).Copy P(i + 1, 1)
      P(i + 1, 5) = DateAdd("m", 6, P(i, 5))
    End If
  Next
Next
End Sub

Fichier (8).

A+

 

[BRUNO62]

Re : Inserer ligne automatiquement avec condition

Bonjour Job75,

C'est Ok, grand Merci
Bonne journée
A+

 

[BRUNO62]

Re : Inserer ligne automatiquement avec condition

Bonjour,
J'ai besoin d'aide, j'ai modifié ma demande.
A partir de la colonne B pour les données ("D712"), je souhaiterais insérer automatiquement deux lignes supplémentaires reprenant les données de celle-ci en incrémentant la colonne F de 4 mois.
J'ai essayé de modifier la macro de Job75 mais je n'arrive pas à un résultat.
Merci, d'avance
A+

 

[job75]

Re : Inserer ligne automatiquement avec condition

Re,

Sub Insere2lignes()
Dim P As Range, ncol%, code, c, i&
Set P = Range("B3:G" & [B3].End(xlDown).Row) 'à adapter
ncol = P.Columns.Count
code = Array("D712") 'les codes à traiter
Application.ScreenUpdating = False
For Each c In code
  For i = P.Rows.Count To 1 Step -1
    If P(i, 1) = c Then
      P(i + 1, 1).Resize(2, ncol).Insert xlDown
      P(i, 1).Resize(, ncol).Copy P(i + 1, 1).Resize(2)
      P(i + 1, 5) = DateAdd("m", 4, P(i, 5))
      P(i + 2, 5) = DateAdd("m", 4, P(i + 1, 5))
    End If
  Next
Next
End Sub

Fichier joint.

Remarque sur la durée d'exécution.

Si l'on clique plusieurs fois de suite sur le bouton la durée d'exécution augmente très vite.

Avec 7 clics elle atteint chez moi 17 secondes (le tableau contient alors 4400 lignes).

Je vous prépare une solution par tableau VBA bien plus rapide.

A+

 

[job75]

Re : Inserer ligne automatiquement avec condition

Re,

Voici la solution par tableau VBA :

Sub Insere2lignes()
Dim P As Range, ncol%, nlig&, code, c, t, i&, n&, j%
Set P = Range("B3:G" & Range("B" & Rows.Count).End(xlUp).Row) 'à adapter
ncol = P.Columns.Count
nlig = P.Rows.Count
code = Array("D712") 'les codes à traiter
'---dimensions du tableau final---
For Each c In code
  nlig = nlig + 2 * Application.CountIf(P.Columns(1), c)
Next
If nlig + 2 > Rows.Count Then MsgBox "Le nouveau tableau sort de la feuille !": Exit Sub
ReDim t(1 To nlig, 1 To ncol) 'tableau VBA, base 1
'---remplissage du tableau VBA---
For i = 1 To P.Rows.Count
  n = n + 1
  For j = 1 To ncol
    t(n, j) = P(i, j)
  Next
  For Each c In code
    If P(i, 1) = c Then
      For j = 1 To ncol
        t(n + 1, j) = t(n, j)
        t(n + 2, j) = t(n, j)
      Next
      t(n + 1, 5) = DateAdd("m", 4, t(n, 5))
      t(n + 2, 5) = DateAdd("m", 4, t(n + 1, 5))
      n = n + 2
    End If
  Next
Next
'---formatage et restitution---
Application.ScreenUpdating = False
If nlig > 1 Then P.Rows(2).Copy P.Rows(2).Resize(nlig - 1)
P.Rows(1).Resize(nlig) = t
End Sub

Maintenant au 7ème clic (4400 lignes) la durée d'exécution n'est que de 0,28 s.

Evidemment la macro est un peu plus difficile à comprendre...

Fichier (2).

Edit : ajouté message de sécurité sur nlig.

A+

 

[BRUNO62]

Re : Inserer ligne automatiquement avec condition

Bonsir Job75,
C'est Ok, grand merci
Bonne soirée
A+