Insertion de ligne en fonction de valeur d'une cellule

[momo]

Je voudrais Insérer des lignes en fonction des valeurs se trouvant dans la colonne H ; La Macro ci après est celle que j'essaie sans succès . Pourriez vous me porter un pti coup d'aide
Merci

La Macro

Sub insererLig()
Dim lig As Long
Application.ScreenUpdating = False
For lig = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
If Cells(lig, "B") <> Cells(lig + 1, "B") And Cells(lig, "H") > 0 Then
Rows(lig + 1).Resize(Cells(lig, "H")).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(lig + 1, 2).Resize(Cells(lig, "H"), 1) = Cells(lig, "B")
End If
Next lig
Application.ScreenUpdating = True
End Sub

 

[job75]

Re : Insertion de ligne en fonction de valeur d'une cellule

Bonsoir momo,

Il suffirait de quelques lignes montrant le résultat désiré pour qu'on puisse donner la solution adéquate.

A+

 

[momo]

Re : Insertion de ligne en fonction de valeur d'une cellule

Bonsoir Job

Merci de bien vouloir me porter votre aide

Je joins le fichier avec quelques exemples de ce que devrait donner le résultat attendu

Merci encore

 

[job75]

Re : Insertion de ligne en fonction de valeur d'une cellule

Bonjour momo,

A partir des exemples fournis voici 2 solutions dans les fichiers joints :

Sub InsererLignes()
Dim derlig As Long, lig As Long
Application.ScreenUpdating = False
derlig = Cells(Rows.Count, 2).End(xlUp).Row
For lig = derlig To 2 Step -1
  If IIf(lig = derlig, True, Cells(lig + 1, 8) <> "") And Cells(lig, 8) > 0 Then
    Rows(lig + 1).Resize(Cells(lig, 8)).Insert
    Cells(lig, 1).Resize(, 6).Copy Cells(lig + 1, 1).Resize(Cells(lig, 8), 6)
  End If
Next lig
End Sub

Sub InsererLignes()
Dim t, ref, rest(), h&, i&, n&, j As Byte, k&
With [A1].CurrentRegion.Resize(, 8).Offset(1)
  t = .FormulaR1C1
  ref = .Columns(8)
  ReDim rest(1 To UBound(t) + Application.SumIf(.Columns(8), ">0"), 1 To 8)
End With
h = UBound(t) - 1
For i = 1 To h
  n = n + 1
  For j = 1 To 8: rest(n, j) = t(i, j): Next
  If IIf(i = h, True, ref(i + 1, 1) <> "") And ref(i, 1) > 0 Then
    For k = n + 1 To n + ref(i, 1)
      For j = 1 To 6
        rest(k, j) = t(i, j)
    Next j, k
    n = n + ref(i, 1)
  End If
Next i
If n Then [A2].Resize(n, 8) = rest
End Sub

La 2ème solution utilise des tableaux VBA, elle est beaucoup plus rapide.

A+

 

[momo]

Re : Insertion de ligne en fonction de valeur d'une cellule

C'est Fantastique!!!!

Merci beaucoup Job, vous êtes vraiment fort

 

[job75]

Re : Insertion de ligne en fonction de valeur d'une cellule

Re,

J'ai copié le tableau de 358 lignes jusqu'à la ligne 10741.

Sur Win 8 - Excel 2013 la 1ère solution s'exécute en 21 secondes.

La seconde solution (tableaux VBA) en 0,56 seconde.

Bonne fin de soirée.

 

[momo]

Re : Insertion de ligne en fonction de valeur d'une cellule

Merci Infiniment... JE sais tout de suite laquelle des méthodes je devrai utiliser

 

[job75]

Re : Insertion de ligne en fonction de valeur d'une cellule

Bonjour momo,

Pour terminer voici je pense une solution meilleure.

Les lignes dont la colonne H n'est pas vide sont toujours traitées :

Sub InsererLignes()
Dim t, ref, rest(), i&, n&, j As Byte, k&
With [A1].CurrentRegion.Resize(, 8).Offset(1)
  t = .FormulaR1C1
  ref = .Columns(8)
  ReDim rest(0 To Application.CountA(.Columns(8)) _
    + Application.SumIf(.Columns(8), ">0"), 1 To 8)
End With
For i = 1 To UBound(t) - 1
  If Not IsEmpty(ref(i, 1)) Then
    For j = 1 To 8: rest(n, j) = t(i, j): Next
    If ref(i, 1) > 0 Then
      For k = n + 1 To n + ref(i, 1)
        For j = 1 To 6
          rest(k, j) = t(i, j)
      Next j, k
      n = n + ref(i, 1)
    End If
    n = n + 1
  End If
Next i
If n Then [A2].Resize(n, 8) = rest
End Sub

Fichier (2).

La durée d'exécution est inchangée.

Mais si après traitement on supprime des lignes "vides" elles seront restituées au traitement suivant.

A+

 

[job75]

Re : Insertion de ligne en fonction de valeur d'une cellule

Re,

Notez enfin qu'il est facile de supprimer les lignes insérées (vides en colonne H) :

Sub SupprimerLignes()
Dim t, i&, n&, j As Byte
t = [A1].CurrentRegion.Resize(, 8).Offset(1).FormulaR1C1
For i = 1 To UBound(t) - 1
  If t(i, 8) <> "" Then
    n = n + 1
    For j = 1 To 8
      t(n, j) = t(i, j)
    Next j
  End If
Next i
If n Then [A2].Resize(n, 8) = t
[A2].Offset(n).Resize(UBound(t) - n, 8).ClearContents
With ActiveSheet.UsedRange: End With 'actualise la barre de défilement
End Sub

Fichier joint.

A+

 

[job75]

Re : Insertion de ligne en fonction de valeur d'une cellule

Re,

Une dernière précision.

S'il y a un texte ou une valeur d'erreur en colonne H les macros InsérerLignes précédentes beuguent.

Un bug est toujours utile pour signaler une bêtise mais on peut l'éviter en ajoutant le test :

If IsNumeric(ref(i, 1)) Then

Fichier (2).

Edit : pour l'entrée éventuelle de nombres décimaux j'utilise 2 * Application.CountA(.Columns(8))

Bonne fin de soirée.

 

[momo]

Re : Insertion de ligne en fonction de valeur d'une cellule

Bonjour Job,

J'ai essayé la dernière méthode proposée, je suis vraiment scotché..

Vous avez même anticipé sur les problèmes que je pourrai avoir et la solution de suppression des lignes iunsérées est géniale ... J'avais voulu revenir sur l'insertion et franchement j'ai été bluffé

Merci encore pour toute l'aide que vous m'avez porté