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

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
 

Fichiers joints

Calvus

XLDnaute Barbatruc
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+
 

Fichiers joints

job75

XLDnaute Barbatruc
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+
 

Fichiers joints

Calvus

XLDnaute Barbatruc
Bonjour Job75, le fil,

J'espère que tu vas bien :)

Il y a peu de réponses car c'est assez compliqué
Toujours aussi impressionnants tes codes !

Tu penses que ma solution ne fonctionne pas dans le cas d'une centaine de lignes ou quelques centaines ?

A+
 

job75

XLDnaute Barbatruc
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+
 

Calvus

XLDnaute Barbatruc
Re,

Oui c'est vrai...
Mais en même temps, il est difficile d'avoir des enfants, puis de ne plus en avoir, puis d'avoir à nouveau...
 

thomasdu43

XLDnaute Occasionnel
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" ?
 

Discussions similaires


Haut Bas