XL 2010 Personnalisation cellules suite insertion de lignes en fonction d'une valeur

  • Initiateur de la discussion Initiateur de la discussion thomasdu43
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

thomasdu43

XLDnaute Occasionnel
Bonjour,
J'ai vu plusieurs posts sur l'insertion de lignes en fonction de la valeur d'une cellule sépcifique.
Je souhaiterai que le contenu d'une cellule de ces lignes insérées soit défini par avance. Exemple dans le fichier joint, si j'inscris la valeur "oui" en B3 et le résultat est la création de 4 lignes dont le contenu de la cellule A4, A5, A6 et A7 est respectivement "Enfant 1", "Enfant 2", "Enfant 3", "Enfant 4".

Je vous remercie de votre aide.

A bientôt
 

Pièces jointes

Bonjour,

Voir l'exemple joint si j'ai bien compris la demande.
VB:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Byte
If Not Intersect(Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row), Target) Is Nothing And Target.Count = 1 Then
        If Target = "Oui" Then
            For i = 1 To 4
                Target.Offset(i, 0).EntireRow.Insert
                Target.Offset(i, -1) = "Enfant " & i
            Next i
        End If
End If
End Sub

A+
 

Pièces jointes

Bonjour thomasdu43, Calvus,

Il y a peu de réponses car c'est assez compliqué, j'ai dû m'y reprendre à plusieurs fois.

S'il y a beaucoup de lignes il faut utiliser des tableaux VBA pour aller vite :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ncol%, tablo, ub&, i&, n&, j%, k&
With UsedRange
    ncol = .Columns.Count
    If ncol = 1 Then ncol = 2 'sécurité
    tablo = .Resize(.Rows.Count + 1, ncol)
    ub = UBound(tablo) - 1
    ReDim resu(1 To UBound(tablo) + 4 * Application.CountIf(.Columns(2), "Oui"), 1 To ncol)
    For i = 1 To UBound(tablo) - 1
        If Not LCase(tablo(i, 1)) Like "enfant#" Then
            n = n + 1
            For j = 1 To ncol
                resu(n, j) = tablo(i, j)
            Next j
            If LCase(tablo(i, 2)) = "oui" Then
                If LCase(tablo(i + 1, 1)) Like "enfant#" Then
                    For k = i + 1 To ub
                        n = n + 1
                        For j = 1 To ncol
                            resu(n, j) = tablo(k, j)
                        Next j
                        If Not LCase(tablo(k, 1)) Like "enfant#" Then Exit For
                    Next
                    i = k
                Else
                    For k = 1 To 4
                        n = n + 1
                        resu(n, 1) = "Enfant" & k
                    Next k
                End If
            End If
        End If
    Next i
    Application.ScreenUpdating = False
    Application.EnableEvents = False 'désactive les évènements
    If FilterMode Then ShowAllData 'si la feuille est filtrée
    .Value = Empty 'RAZ
    .Cells(1).Resize(n, ncol) = resu 'restitution
    Application.EnableEvents = True 'réactive les évènements
End With
With UsedRange: End With 'actualise les barres de défilement
End Sub
Fichier joint, sur 60 000 lignes initiales (140 000 finales) la macro s'exécute chez moi en 1,5 seconde.

A+
 

Pièces jointes

Tout dépend de ce que l'on veut faire Calvus, ta solution peut suffire mais elle est très incomplète :

- elle ne fonctionne que si une seule cellule est modifiée

- si l'on remplace le "Oui" par "Non" les "Enfant?" ne s'effacent pas

- si l'on remet le "Oui" on aura 8 "Enfant?"...

A+
 
Bonjour,

Voir l'exemple joint si j'ai bien compris la demande.
VB:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Byte
If Not Intersect(Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row), Target) Is Nothing And Target.Count = 1 Then
        If Target = "Oui" Then
            For i = 1 To 4
                Target.Offset(i, 0).EntireRow.Insert
                Target.Offset(i, -1) = "Enfant " & i
            Next i
        End If
End If
End Sub

A+
Merci Calvus, c'est ça, maintenant y a-t-il une possibilité de réversibilité si je saisis "non" ?
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Retour