inserer une ligne sous condition (VBA)

[pascal21]

bonjour le forum
après de multiples recherches sur le net, je n'ai pas trouvé de réponse que je puisse exploiter avec mes maigres connaissances en VBA
en gros tout est dans le titre et dans le fichier joint que j'ai essayé de rendre le plus explicite possible
il s'agit, par exemple, d'inserer sur la ligne 12 un texte si ligne 11 col G il y a "OK"
merci de votre aide

 

[job75]

Bonjour pascal21,

Le forum fourmille d'exemples de ce genre :

Sub Insertion()
Dim i&
Application.ScreenUpdating = False
For i = Range("G" & Rows.Count).End(xlUp).Row To 1 Step -1
  If Cells(i, 7) = "ok" Then
    Rows(i + 1).Insert
    Cells(i + 1, 1) = Cells(i, 1)
    Cells(i + 1, 2) = Date 'date du jour
    Cells(i + 1, 3) = "Bonus + de 90 jours"
    Cells(i + 1, 4) = 30
  End If
Next
End Sub

Cela peut prendre beaucoup de temps s'il y a un grand nombre de lignes à insérer.

A+

 

[pascal21]

Bonjour job je vais tester de ce pas

 

[pascal21]

ça fonctionne mais ça fonctionne trop bien
car à chaque clic ça rajoute une ligne bonus

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Insertion
End Sub

il faudrait que je trouve une condition qui empêche la repetition du code une fois la condition remplie

 

[pascal21]

j'ai ajouté cette modif qui à priori, a l'air de convenir
sous reserve d'essais un peu plus poussés

Sub Insertion()
Dim i&
Application.ScreenUpdating = False
For i = Range("G" & Rows.Count).End(xlUp).Row To 1 Step -1
'Next

If Cells(i, 7) = "ok" Then
If Cells(i + 1, 3).Value = "Bonus + de 90 jours" Then
Exit Sub
Else
    Rows(i + 1).Insert
    Cells(i + 1, 1) = Cells(i, 1)
    Cells(i + 1, 2) = Date 'date du jour
    Cells(i + 1, 3) = "Bonus + de 90 jours"
    'Cells(i + 1, 4) = 30
  End If
  End If
Next
End Sub

 

[youky(BJ)]

Bonjour tous,
Petit complément à la macro de Job75 afin d'éviter le rajout de ligne si l'on fait tourner la macro à plusieurs reprises.
Pas grand chose à modifier , j'avais fait une macro similaire mais Job a été plus rapide....
If Cells(i, 7) = "ok" And Cells(i + 1, 7) <> "" Then

Bruno

 

[pascal21]

merci Bruno
entre temps j'avais inseré une instruction de condition pour éviter la repet
mais un autre petit soucis montre le bout de son nez
en colonne D j'ai une formule de recherche

=SI(ESTERREUR(RECHERCHEV($C9;liste_événements;2;0));"";RECHERCHEV($C9;liste_événements;2;0))

pour la ligne 9 par exemple
lors de l'ajout de la ligne "bonus, il faudrait que cette formule soit inscrite egalement
j'ai essayé avec ceci

Cells(i + 1, 4) = FormulaLocal = "=SI(ESTERREUR(RECHERCHEV($C7;liste_événements;3;0));"";RECHERCHEV($C7;liste_événements;3;0))"

mais la formule ne s'inscrit pas dans la colonne j'ai juste ""FAUX" qui s'inscrit alors que la formule devrait renvoyer
la valur 30

 

[youky(BJ)]

Hello,
Essaie cette macro

Sub Insertion()
Dim i&
Application.ScreenUpdating = False
For i = Range("G" & Rows.Count).End(xlUp).Row To 1 Step -1
  If Cells(i, 7) = "ok" And Cells(i, 3) <> "Bonus + de 90 jours" Then
  Cells(i, 4).Copy
    Rows(i + 1).Insert
    Cells(i + 1, 1) = Cells(i, 1)
    Cells(i + 1, 2) = Date 'date du jour
    Cells(i + 1, 3) = "Bonus + de 90 jours"
    Cells(i + 1, 4).PasteSpecial
  End If
Next
End Sub

Bruno

 

[pascal21]

merci j'ai essayé mais sur mon classeur ça me recopiait la cellule d sur toute la ligne inférieure
j'ai triché en rajoutant à la fin du code une macro avec l'enregistreur de copie/recopie-formule
et ça fonctionne
maintenant comment modifier cette ligne pour que ça ne concerne que les lignes 10 à 1000
ceci pour accélérer la macro
merci

 

[pascal21]

je viens de m'apercevoir d'une gros soucis en fait
donc il faut rajouter un bonus si le dernier malus date de plus de trois mois
dans l'état ça fonctionne

mais si entre temps un autre malus vient se rajouter au même employé le bonus ne devrait pas être attribué
il faudrait:
que ça ne concerne que la dernière ligne malus de chaque employé
que pour les périodes de plus de 90 jours sans malus de chaque employé
et là je cale

 

[youky(BJ)]

Nouvelle macro, j'avais oublié +1 et ligne 10 à 1000 ok
La macro part du bas et remonte; l'insertion de ligne se fera qu'une fois par nom
exemple si en bas dede est "ok" j'insere une ligne si je retrouve dede plus haut rien ne se passe

Sub Insertion()
Dim i&
Application.ScreenUpdating = False
Set dico = CreateObject("Scripting.Dictionary")
'For i = Range("G" & Rows.Count).End(xlUp).Row To 1 Step -1
For i = 1000 To 10 Step -1
  If Cells(i, 7) = "ok" And Cells(i + 1, 3) <> "Bonus + de 90 jours" Then
        If Not dico.Exists(Cells(i, 1)) And Cells(i, 1) <> "" Then
            dico.Add Cells(i, 1), Cells(i, 1)
            Cells(i, 4).Copy
            Rows(i + 1).Insert
            Cells(i + 1, 1) = Cells(i, 1)
            Cells(i + 1, 2) = Date 'date du jour
            Cells(i + 1, 3) = "Bonus + de 90 jours"
            Cells(i + 1, 4).PasteSpecial
        End If
  End If
Next
End Sub

Bruno

 

[pascal21]

merci pour ton aide mais sur mon classeur ça ne change rien meme pire en fait
puisque si il y a d'autres lignes au dessus d'éligibles elles ne sont pas prises en compte
il faut que pour chaque employé il y est une période 90 jours mini entre deux malus pour pouvoir prétendre à ce bonus
si c'est trop compliqué tant pis je garderai les sous pour moi lol!!!!
edit; au temps moi en fait c'est moi qu'il ai fait une betise en recopiant la formule sur mon classeur
merci ça à l'air de fonctionner comme ça
faut que je continue de debuguer

 

[job75]

Re, salut Bruno,

Si je comprends bien maintenant il faut commencer à la ligne 10...

Avec des tableaux VBA c'est normalement très rapide, même s'il y a un grand nombre de lignes :

Sub Insertion_Tableaux()
Dim P As Range, t, ref, rest(), d As Object, i&, n&, j%
Set P = Intersect(Range("A10:G" & Rows.Count), ActiveSheet.UsedRange.EntireRow)
If P Is Nothing Then Exit Sub
t = P.Resize(P.Rows.Count + 1).FormulaR1C1 'tableau des formules
ref = P.Resize(P.Rows.Count + 1).Columns(7) 'au moins 2 cellules
ReDim rest(1 To UBound(t) + Application.CountIf(P.Columns(7), "ok"), 1 To 7)
'---détermination des lignes à traiter (dernier malus ok)---
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t) - 1
  If ref(i, 1) = "ok" And t(i + 1, 3) <> "Bonus + de 90 jours" Then d(t(i, 1)) = i
Next
'---création du tableau rest---
For i = 1 To UBound(t) - 1
  n = n + 1
  For j = 1 To 7
    rest(n, j) = t(i, j)
  Next
  If i = d(t(i, 1)) Then
    n = n + 1 'ligne ajoutée
    rest(n, 1) = t(i, 1)
    rest(n, 2) = Date 'date du jour
    rest(n, 3) = "Bonus + de 90 jours"
    rest(n, 4) = t(i, 4) 'copie de la formule en colonne D
  End If
Next
'---restitution---
Set P = P.Resize(n)
P.Rows(1).AutoFill P, xlFillFormats 'copie les formats
Application.DisplayAlerts = False 'facultatif, s'il y a des liaisons avec un classeur inconnu...
P.FormulaR1C1 = rest
End Sub

Il n'y a plus d'insertion de lignes mais décalage dans le tableau.

Cela dit toutes les formules sont recalculées, cela peut prendre du temps...

A+

 

[job75]

Bonjour Pascal, Bruno,

La feuille peut avoir été filtrée ou triée dans n'importe quel ordre.

Dans ce cas il faut utiliser cette macro :

Sub Insertion_Tableaux()
Dim P As Range, t, ref, rest(), d As Object, i&, n&, j%
Set P = Intersect(Range("A10:G" & Rows.Count), ActiveSheet.UsedRange.EntireRow)
If P Is Nothing Then Exit Sub
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
P.Sort P(1, 2), xlAscending, , P(1), , P(1, 7), Header:=xlNo 'tri sur les dates
t = P.Resize(P.Rows.Count + 1).FormulaR1C1 'tableau des formules
ref = P.Resize(P.Rows.Count + 1).Columns(7) 'au moins 2 cellules
ReDim rest(1 To UBound(t) + Application.CountIf(P.Columns(7), "ok"), 1 To 7)
'---détermination des lignes à traiter (dernier malus ok)---
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t) - 1
  If ref(i, 1) = "ok" And t(i + 1, 3) <> "Bonus + de 90 jours" Then d(t(i, 1)) = i
Next
'---création du tableau rest---
For i = 1 To UBound(t) - 1
  n = n + 1
  For j = 1 To 7
    rest(n, j) = t(i, j)
  Next
  If i = d(t(i, 1)) Then
    n = n + 1 'ligne ajoutée
    rest(n, 1) = t(i, 1)
    rest(n, 2) = t(i, 2)
    rest(n, 3) = "Bonus + de 90 jours"
    rest(n, 4) = t(i, 4) 'copie de la formule en colonne D
  End If
Next
'---restitution---
Set P = P.Resize(n)
P.Rows(1).AutoFill P, xlFillFormats 'copie les formats
Application.DisplayAlerts = False 'facultatif, s'il y a des liaisons avec un classeur inconnu...
P.FormulaR1C1 = rest
End Sub

La date mise au bonus créé doit être impérativement celle du dernier malus "ok".

A+

 

[Usine à gaz]

Bonjour Job75, le forum,

je regarde régulièrement les fils et je suis toujours impressionné par vos codes et conseils
Merci pour tant de gentillesse et de faire profiter de votre technicité.
Bon réveillon à toutes et à tous,
Amicalement,
Lionel,