Plantage avec l’élément WorkSheet_Change

Bonjour

Alors Voila je dispose de se code suivant que j'ai réalisé grâce a l'aide de se forum :

Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False

'Désactivation du raffraichissement de l'écran

ActiveSheet.Unprotect

'Dévérouiller la page active

Dim lo As ListObject

Dim rng As Range, rng2 As Range

Dim LR As ListRow

Dim lCol As Long

Dim N As Double

Application.ScreenUpdating = False

For Each lo In ActiveSheet.ListObjects

If lo.InsertRowRange Is Nothing Then

lCol = lo.ListColumns.Count

On Error Resume Next

Set rng = lo.DataBodyRange.Offset(, 1).Resize(, lCol - 1) _

.SpecialCells(xlCellTypeBlanks)

On Error GoTo 0

If Not rng Is Nothing Then

Set rng = Nothing

For Each LR In lo.ListRows

Set rng = LR.Range.Offset(, 1).Resize(1, lCol - 1)

N = WorksheetFunction.CountA(rng)

If N = 0 Then

If rng2 Is Nothing Then

Set rng2 = LR.Range

Else

Set rng2 = Union(LR.Range, rng2)

End If

End If

Set rng = Nothing

Next LR

End If

End If

If Not rng2 Is Nothing Then

rng2.Delete

Set rng2 = Nothing

End If

'Supprimer les lignes vides des tableaux

lo.ListRows.Add

'Ajouter une nouvelle ligne a chaque tableaux

Next lo

ActiveSheet.Protect

'Vérouiller la page active

Application.ScreenUpdating = True

'Réactivation du raffraichissement de l'écran

End Sub

Sauf que se code me fait planter excel :/ je ne sais que faire. Pourtant lorsque je l’exécute avec un sub normal grâce a un bouton cela marche nickel. Pourquoi ?

Merci d'avance

Bonjour,

C'est bien sympa, en plus du fichier qui contient déjà le code, de remplir les pages, mais si tu disais ce que tu veux comme résultat ?

RE,

essaie ainsi :

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lo As ListObject
Dim rng As Range, rng2 As Range
Dim LR As ListRow
Dim lCol As Long
Dim N As Double
    'Désactivation du raffraichissement de l'écran
    Application.ScreenUpdating = False
    'Dévérouiller la page active
    Me.Unprotect
    For Each lo In Me.ListObjects
        If lo.InsertRowRange Is Nothing Then
            lCol = lo.ListColumns.Count
            On Error Resume Next
            Set rng = lo.DataBodyRange.Offset(, 1).Resize(, lCol - 1) _
                      .SpecialCells(xlCellTypeBlanks)
            On Error GoTo 0
            If Not rng Is Nothing Then
                Set rng = Nothing
                For Each LR In lo.ListRows
                    Set rng = LR.Range.Offset(, 1).Resize(1, lCol - 1)
                    N = WorksheetFunction.CountA(rng)
                    If N = 0 Then
                        If rng2 Is Nothing Then
                            Set rng2 = LR.Range
                        Else
                            Set rng2 = Union(LR.Range, rng2)
                        End If
                    End If
                    Set rng = Nothing
                Next LR
            End If
        End If
        If Not rng2 Is Nothing Then
            Application.EnableEvents = False
            'Supprimer les lignes vides des tableaux
            rng2.Delete
            Application.EnableEvents = True
            Set rng2 = Nothing
        End If
    Next lo
    'Verrrouiller la page active
    Me.Protect
End Sub

Le problème me semblais clair : POURQUOI ça plante ? Comment faire pour éviter ça?

Jean Eric a compris

Il manque juste l'ajout de la ligne a la fin pour qu'il y ai toujours une ligne dispo. que faire

Merci d'avance

Jean-Eric a écrit :

RE,

essaie ainsi :

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lo As ListObject
Dim rng As Range, rng2 As Range
Dim LR As ListRow
Dim lCol As Long
Dim N As Double
    'Désactivation du raffraichissement de l'écran
    Application.ScreenUpdating = False
    'Dévérouiller la page active
    Me.Unprotect
    For Each lo In Me.ListObjects
        If lo.InsertRowRange Is Nothing Then
            lCol = lo.ListColumns.Count
            On Error Resume Next
            Set rng = lo.DataBodyRange.Offset(, 1).Resize(, lCol - 1) _
                      .SpecialCells(xlCellTypeBlanks)
            On Error GoTo 0
            If Not rng Is Nothing Then
                Set rng = Nothing
                For Each LR In lo.ListRows
                    Set rng = LR.Range.Offset(, 1).Resize(1, lCol - 1)
                    N = WorksheetFunction.CountA(rng)
                    If N = 0 Then
                        If rng2 Is Nothing Then
                            Set rng2 = LR.Range
                        Else
                            Set rng2 = Union(LR.Range, rng2)
                        End If
                    End If
                    Set rng = Nothing
                Next LR
            End If
        End If
        If Not rng2 Is Nothing Then
            Application.EnableEvents = False
            'Supprimer les lignes vides des tableaux
            rng2.Delete
            Application.EnableEvents = True
            Set rng2 = Nothing
        End If
    Next lo
    'Verrrouiller la page active
    Me.Protect
End Sub

Help please !!

Il me manquerait juste l'ajout de ligne a la fin

Je l'avais noté ainsi mais il ne fonctionne plus dans ta formule donné :/ :

lo.ListRows.Add

Merci par avance