XL 2016 Erreur de compilation VBA

[dilack]

Bonjour à tous,

J'ai créer un fichier en m'aidant de "DV_AjoutListe.xls" de Mr Jacques Boisgontier à l'adresse suivante:
DV_ajoutListe.xls

Mes compétences en VBA sont plus que limité pour compiler plusieur le codes afin de d'ajouter un élément qui n'appartient pas à une liste.

une exemple si dans ma liste "LTYPE" l'élément n'existe pas il est ajouter à liste "LTYPE", ensuite si dans ma liste "LGEO" l'élément n'existe pas il est ajouter et ainsi de suite ...

Je vous mets le fichier avec des annotations, ça seras peut être plus simple pour me comprendre !

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Column = 2 And Target.Count = 1 Then
  If Target <> "" Then
    If IsError(Application.Match(Target.Value, [LTYPE], 0)) Then
      If MsgBox("On ajoute?", vbYesNo) = vbYes Then
        [LTYPE].End(xlDown).Offset(1, 0) = Target.Value
        Sheets("DATA").[LTYPE].Sort key1:=Sheets("DATA").Range("B2")
      Else
        Application.Undo
      End If
     End If
   End If
  End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Column = 5 And Target.Count = 1 Then
  If Target <> "" Then
    If IsError(Application.Match(Target.Value, [LGEO], 0)) Then
      If MsgBox("On ajoute?", vbYesNo) = vbYes Then
        [LGEO].End(xlDown).Offset(1, 0) = Target.Value
        Sheets("DATA").[LGEO].Sort key1:=Sheets("DATA").Range("E2")
      Else
        Application.Undo
      End If
     End If
   End If
  End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Column = 8 And Target.Count = 1 Then
  If Target <> "" Then
    If IsError(Application.Match(Target.Value, [LMAT], 0)) Then
      If MsgBox("On ajoute?", vbYesNo) = vbYes Then
        [LMAT].End(xlDown).Offset(1, 0) = Target.Value
        Sheets("DATA").[LMAT].Sort key1:=Sheets("DATA").Range("H2")
      Else
        Application.Undo
      End If
     End If
   End If
  End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Column = 10 And Target.Count = 1 Then
  If Target <> "" Then
    If IsError(Application.Match(Target.Value, [LCLASSE], 0)) Then
      If MsgBox("On ajoute?", vbYesNo) = vbYes Then
        [LCLASSE].End(xlDown).Offset(1, 0) = Target.Value
        Sheets("DATA").[LCLASSE].Sort key1:=Sheets("DATA").Range("J2")
      Else
        Application.Undo
      End If
     End If
   End If
  End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Column = 12 And Target.Count = 1 Then
  If Target <> "" Then
    If IsError(Application.Match(Target.Value, [LOUVERTURE], 0)) Then
      If MsgBox("On ajoute?", vbYesNo) = vbYes Then
        [LOUVERTURE].End(xlDown).Offset(1, 0) = Target.Value
        Sheets("DATA").[LOUVERTURE].Sort key1:=Sheets("DATA").Range("L2")
      Else
        Application.Undo
      End If
     End If
   End If
  End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Column = 15 And Target.Count = 1 Then
  If Target <> "" Then
    If IsError(Application.Match(Target.Value, [LPOSI], 0)) Then
      If MsgBox("On ajoute?", vbYesNo) = vbYes Then
        [LPOSI].End(xlDown).Offset(1, 0) = Target.Value
        Sheets("DATA").[LPOSI].Sort key1:=Sheets("DATA").Range("O2")
      Else
        Application.Undo
      End If
     End If
   End If
  End If
End Sub

Merci d'avance de vos lumières...

 

[Dranreb]

Bonjour.
Vous ne pouvez écrire qu'une seule Sub Worksheet_Change par objet Worksheet.
Commencez la par :

   If Target.CountLarge > 1 Then Exit Sub
   Select Case Target.Column
   Case 2:

puis le code de la 1ère. Case 5: celui de la 2nde etc.
Terminez par End Select.

 

[Hasco]

Bonjour,

Voyez dans le fichier joint si cela convient:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim liste As Range
    If Not Intersect(Target, Range("A1").CurrentRegion) Is Nothing And Target.CountLarge = 1 And Target <> "" Then
        '
        ' Choisir la bonne liste en fonction de l'entête de colonne
        With Sheets("DaTA")
            Select Case Cells(1, Target.Column)
            Case "Type": Set liste = .Range("LTYPE")
            Case "Géométrie": Set liste = .Range("LGEO")
            Case "Matériaux": Set liste = .Range("LMAT")
            Case "Classe": Set liste = .Range("LCLASSE")
            End Select
        End With
        '
        ' si la liste a été choisie
        If Not liste Is Nothing Then
            If IsError(Application.Match(Target.Value, [LTYPE], 0)) Then
                If MsgBox("On ajoute?", vbYesNo) = vbYes Then
                    With liste
                        .Offset(liste.Rows.Count).Resize(1, 1) = Target.Value
                        .Sort key1:=.Cells(2, 1)
                    End With
                Else
                    Application.EnableEvents = False
                    Target = Empty
                    Application.EnableEvents = True
                End If
            End If

        End If
    End If
End Sub

Bon après-midi

 

[dilack]

Merci à tous les deux d'avoir pris le temps le répondre,

@Danreb: je vais essayer de terminer le code avec ta solution, mais avant ça faut comprendre....

@Roblochon: oui cela fonctionne trés bien, j'ai plus qu'a rajouter mes autre colonnes...