Problème fonction modifier ligne VBA

Le 20/09/2017 à 09:57

Bonjour a tous

Je vient vous sollicité, j'ai crée un userform tout fonctionne correctement sauf le bouton modifier

J'ai tester une multitude de code sans sucée

Pouvez-vous m'aider svp, le principe est de rechercher une ligne via le bouton recherche changer les donnés et cliquer sur le bouton modifier afin de corriger la ligne en question.

voici mon code :

Dim f

'Pour le formulaire
Private Sub Formulaire_Initialize()

    Me.NomdeBapteme.List = Array("19", "51", "52")
    Me.SGL.List = Array("4100", "4800", "44??")
    Me.CIE.List = Array("1", "2", "CCL", "CADO", "CA")
    Me.GQGN.List = Array("GQ", "GN")

  Set f = Sheets("base")
   Set mondico = CreateObject("Scripting.Dictionary")
   For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
     mondico(c.Value) = ""
   Next c
   Me.EMAT8.AddItem "*"
   For Each i In mondico.keys
     Me.EMAT8.AddItem i
   Next
   Me.EMAT8.ListIndex = 0

End Sub

Private Sub EMAT8_Change()
  Set f = Sheets("base")
  Me.ASM.Clear
  For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
    If c = Me.EMAT8 Or Me.EMAT8 = "*" Then
       Me.ASM.AddItem c.Offset(0, 1)
     End If
   Next c
   Me.ASM.ListIndex = 0
End Sub

Private Sub GQGN_Change()

End Sub

'Pour le bouton Nouveau contact
Private Sub nouveau_Click()

    Dim L As Integer

    If MsgBox("Confirmez-vous l’insertion de ce nouveau matériel ?", vbYesNo, "Demande de confirmation d’ajout") = vbYes Then

        L = Sheets("19 RG PARC GLOBAL").Range("a65536").End(xlUp).Row + 1 'Pour placer le nouvel enregistrement à la première ligne de tableau non vide

        Range("A" & L).Value = EMAT8 '

        Range("B" & L).Value = NomdeBapteme '

        Range("C" & L).Value = ASM '

        Range("D" & L).Value = AISM '

        Range("E" & L).Value = SGL '

        Range("F" & L).Value = CIE '

        Range("G" & L).Value = Observation '

        Range("H" & L).Value = GQGN '

    End If

End Sub
Private Sub Recherche_Click()
Dim Lign As Long
With Sheets("19 RG PARC GLOBAL")
If TextBox1 = "" Then Exit Sub
Lign = .Columns(4).Cells.Find(TextBox1).Row
If TextBox2 = "" Then Exit Sub
Lign = .Columns(1).Cells.Find(TextBox2).Row
Me.EMAT8 = .Cells(Lign, 1)
Me.NomdeBapteme = .Cells(Lign, 2)
Me.ASM = .Cells(Lign, 3)
Me.AISM = .Cells(Lign, 4)
Me.SGL = .Cells(Lign, 5)
Me.CIE = .Cells(Lign, 6)
Me.Observation = .Cells(Lign, 7)
Me.GQGN = .Cells(Lign, 8)
End With
End Sub
Private Sub Modification_Click()

End Sub

'Pour le bouton Quitter
Private Sub Quitter_Click()

    Unload Me

End Sub

Private Sub UserForm_Click()

End Sub

Merci pour votre aide.

Le 20/09/2017 à 11:21

Bonjour

à tester,

j'ai ajouté un dim en début de module et complété la partie modification, n'ayant pas de fichier je n'ai pas pu tester.

Dim f, lign

'Pour le formulaire
Private Sub Formulaire_Initialize()

    Me.NomdeBapteme.List = Array("19", "51", "52")
    Me.SGL.List = Array("4100", "4800", "44??")
    Me.CIE.List = Array("1", "2", "CCL", "CADO", "CA")
    Me.GQGN.List = Array("GQ", "GN")

    Set f = Sheets("base")
    Set mondico = CreateObject("Scripting.Dictionary")
    For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
        mondico(c.Value) = ""
    Next c
    Me.EMAT8.AddItem "*"
    For Each i In mondico.keys
        Me.EMAT8.AddItem i
    Next
    Me.EMAT8.ListIndex = 0

End Sub

Private Sub EMAT8_Change()
    Set f = Sheets("base")
    Me.ASM.Clear
    For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
        If c = Me.EMAT8 Or Me.EMAT8 = "*" Then
            Me.ASM.AddItem c.Offset(0, 1)
        End If
    Next c
    Me.ASM.ListIndex = 0
End Sub

Private Sub GQGN_Change()

End Sub

'Pour le bouton Nouveau contact
Private Sub nouveau_Click()

    Dim L As Integer

    If MsgBox("Confirmez-vous l’insertion de ce nouveau matériel ?", vbYesNo, "Demande de confirmation d’ajout") = vbYes Then

        L = Sheets("19 RG PARC GLOBAL").Range("a65536").End(xlUp).Row + 1    'Pour placer le nouvel enregistrement à la première ligne de tableau non vide

        Range("A" & L).Value = EMAT8    '

        Range("B" & L).Value = NomdeBapteme    '

        Range("C" & L).Value = ASM    '

        Range("D" & L).Value = AISM    '

        Range("E" & L).Value = SGL    '

        Range("F" & L).Value = CIE    '

        Range("G" & L).Value = Observation    '

        Range("H" & L).Value = GQGN    '

    End If

End Sub
Private Sub Recherche_Click()
    With Sheets("19 RG PARC GLOBAL")
        If TextBox1 = "" Then Exit Sub
        lign = .Columns(4).Cells.Find(TextBox1).Row
        If TextBox2 = "" Then Exit Sub
        lign = .Columns(1).Cells.Find(TextBox2).Row
        Me.EMAT8 = .Cells(lign, 1)
        Me.NomdeBapteme = .Cells(lign, 2)
        Me.ASM = .Cells(lign, 3)
        Me.AISM = .Cells(lign, 4)
        Me.SGL = .Cells(lign, 5)
        Me.CIE = .Cells(lign, 6)
        Me.Observation = .Cells(lign, 7)
        Me.GQGN = .Cells(lign, 8)
    End With
End Sub
Private Sub Modification_Click()
    L = lign
    Range("A" & L).Value = EMAT8    '

    Range("B" & L).Value = NomdeBapteme    '

    Range("C" & L).Value = ASM    '

    Range("D" & L).Value = AISM    '

    Range("E" & L).Value = SGL    '

    Range("F" & L).Value = CIE    '

    Range("G" & L).Value = Observation    '

    Range("H" & L).Value = GQGN    '

End Sub

'Pour le bouton Quitter
Private Sub Quitter_Click()

    Unload Me

End Sub
Le 20/09/2017 à 13:51

Bonjour.

Merci de la réponse mais cela ne fonctionne pas.

Et j'ai oublier de préciser que le code doit bien préciser l'onglet car ce formulaire vas être ajuster pour d'autre onglet par la suite.

Je joint le fichier.

Merci par avance de votre aide.

14test.zip (138.77 Ko)
Le 20/09/2017 à 15:23

Bonjour,

j'ai adapté les macros. tu as des erreurs dans plages définies, ce qui fait que certaines comboboxes ne sont pas initialisées correctement.

16test.zip (137.72 Ko)
Le 20/09/2017 à 15:54

Bonjour cela ne fonctionne pas

Désoler j'avais oublier de laisser l'onglet base pour mes combobox tout fonctionne correctement je bute juste sur le bouton modifier

Je vous joint le fichier avec cette fois l'onglet base et votre bout de code pour le bouton modification qui ne fonctionne pas désoler du dérangement.

J'ai remis mon code qui est fonctionnel pour tout les autres fonction.

Bonne réception.

12test.zip (137.14 Ko)
Le 20/09/2017 à 16:46

re-bonjour,

je me suis limité à la correction de la procédure de modification et à l'ajout du nom de l'onglet.

Dim f, lign

'Pour le formulaire
Private Sub Formulaire_Initialize()
'cette procédure ne sert à rien, et ne sera jamais exécutée,
' le nom de la procedure d'intialisation d'un userform est userform_initialize
'
    Me.NomdeBapteme.List = Array("19", "51", "52")
    Me.SGL.List = Array("4100", "4800", "44??")
    Me.CIE.List = Array("1", "2", "CCL", "CADO", "CA")
    Me.GQGN.List = Array("GQ", "GN")

    Set f = Sheets("base")
    Set mondico = CreateObject("Scripting.Dictionary")
    For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
        mondico(c.Value) = ""
    Next c
    Me.EMAT8.AddItem "*"
    For Each i In mondico.keys
        Me.EMAT8.AddItem i
    Next
    Me.EMAT8.ListIndex = 0

End Sub

Private Sub EMAT8_Change()
    Set f = Sheets("base")
    Me.ASM.Clear
    For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
        If c = Me.EMAT8 Or Me.EMAT8 = "*" Then
            Me.ASM.AddItem c.Offset(0, 1)
        End If
    Next c
    Me.ASM.ListIndex = 0
End Sub

'Pour le bouton Nouveau contact
Private Sub nouveau_Click()
    Dim L As Integer
    If MsgBox("Confirmez-vous l’insertion de ce nouveau matériel ?", vbYesNo, "Demande de confirmation d’ajout") = vbYes Then
        With Sheets("19 RG PARC GLOBAL")
            L = .Range("a65536").End(xlUp).Row + 1    'Pour placer le nouvel enregistrement à la première ligne de tableau non vide
            .Range("A" & L).Value = EMAT8    '
            .Range("B" & L).Value = NomdeBapteme    '
            .Range("C" & L).Value = ASM    '
            .Range("D" & L).Value = AISM    '
            .Range("E" & L).Value = SGL    '
            .Range("F" & L).Value = CIE    '
            .Range("G" & L).Value = Observation    '
            .Range("H" & L).Value = GQGN    '
        End With
    End If
End Sub
Private Sub Recherche_Click()
    Dim lign As Long
    With Sheets("19 RG PARC GLOBAL")
        If TextBox1 = "" And TextBox2 = "" Then Exit Sub
        If TextBox1 <> "" Then
        Set re = .Columns(4).Cells.Find(TextBox1)
        ElseIf TextBox2 <> "" Then
        Set re = lign = .Columns(1).Cells.Find(TextBox2)
        End If
        If re Is Nothing Then Exit Sub
        lign = re.Row
        Me.EMAT8 = .Cells(lign, 1)
        Me.NomdeBapteme = .Cells(lign, 2)
        Me.ASM = .Cells(lign, 3)
        Me.AISM = .Cells(lign, 4)
        Me.SGL = .Cells(lign, 5)
        Me.CIE = .Cells(lign, 6)
        Me.Observation = .Cells(lign, 7)
        Me.GQGN = .Cells(lign, 8)
    End With
End Sub
Private Sub Modification_Click()
    L = lign
    With Sheets("19 RG PARC GLOBAL")
        .Range("A" & L).Value = EMAT8    '
        .Range("B" & L).Value = NomdeBapteme    '
        .Range("C" & L).Value = ASM    '
        .Range("D" & L).Value = AISM    '
        .Range("E" & L).Value = SGL    '
        .Range("F" & L).Value = CIE    '
        .Range("G" & L).Value = Observation    '
        .Range("H" & L).Value = GQGN    '
    End With

End Sub

'Pour le bouton Quitter
Private Sub Quitter_Click()

    Unload Me

End Sub
Le 20/09/2017 à 17:00

Bonjour

Je vient de faire le test et sa fonctionne pas

j'obtient une erreur d'exécution '1004' Erreur définie par l'application ou par l'objet

Quand je clic sur débogage

cela me positionne sur

.Range("A" & L).Value = EMAT8

Bonne réception.

Le 20/09/2017 à 17:20

Bonjour,

voici le code correct pour la recherche, qui devrait solutionner le problème que tu rencontres avec la modification.

Private Sub Recherche_Click()
    With Sheets("19 RG PARC GLOBAL")
        If TextBox1 = "" And TextBox2 = "" Then Exit Sub
        If TextBox1 <> "" Then
        Set re = .Columns(4).Cells.Find(TextBox1)
        ElseIf TextBox2 <> "" Then
        Set re = .Columns(1).Cells.Find(TextBox2)
        End If
        If re Is Nothing Then Exit Sub
        lign = re.Row
        Me.EMAT8 = .Cells(lign, 1)
        Me.NomdeBapteme = .Cells(lign, 2)
        Me.ASM = .Cells(lign, 3)
        Me.AISM = .Cells(lign, 4)
        Me.SGL = .Cells(lign, 5)
        Me.CIE = .Cells(lign, 6)
        Me.Observation = .Cells(lign, 7)
        Me.GQGN = .Cells(lign, 8)
    End With
End Sub
Le 21/09/2017 à 07:21

Bonjour

Je vient de faire le test le bouton recherche fonctionne bien mais si je fait une modif et que je clic sur modifier il ne se passe rien pas de message d'erreur et la modif n'est pas prise en compte.

Merci de votre aide.

Bonne réception.

Le 21/09/2017 à 09:51

bonjour,

apparemment je n'ai pas envoyé le bon code 

Dim f, lign

'Pour le formulaire
Private Sub Formulaire_Initialize()
'cette procédure ne sert à rien, et ne sera jamais exécutée,
' le nom de la procedure d'intialisation d'un userform est userform_initialize
'
    Me.NomdeBapteme.List = Array("19", "51", "52")
    Me.SGL.List = Array("4100", "4800", "44??")
    Me.CIE.List = Array("1", "2", "CCL", "CADO", "CA")
    Me.GQGN.List = Array("GQ", "GN")

    Set f = Sheets("base")
    Set mondico = CreateObject("Scripting.Dictionary")
    For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
        mondico(c.Value) = ""
    Next c
    Me.EMAT8.AddItem "*"
    For Each i In mondico.keys
        Me.EMAT8.AddItem i
    Next
    Me.EMAT8.ListIndex = 0

End Sub

Private Sub EMAT8_Change()
    Set f = Sheets("base")
    Me.ASM.Clear
    For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
        If c = Me.EMAT8 Or Me.EMAT8 = "*" Then
            Me.ASM.AddItem c.Offset(0, 1)
        End If
    Next c
    'Me.ASM.ListIndex = 0
End Sub

'Pour le bouton Nouveau contact
Private Sub nouveau_Click()
    Dim L As Integer
    If MsgBox("Confirmez-vous l’insertion de ce nouveau matériel ?", vbYesNo, "Demande de confirmation d’ajout") = vbYes Then
        With Sheets("19 RG PARC GLOBAL")
            L = .Range("a65536").End(xlUp).Row + 1    'Pour placer le nouvel enregistrement à la première ligne de tableau non vide
            .Range("A" & L).Value = EMAT8    '
            .Range("B" & L).Value = NomdeBapteme    '
            .Range("C" & L).Value = ASM    '
            .Range("D" & L).Value = AISM    '
            .Range("E" & L).Value = SGL    '
            .Range("F" & L).Value = CIE    '
            .Range("G" & L).Value = Observation    '
            .Range("H" & L).Value = GQGN    '
        End With
    End If
End Sub
Private Sub Recherche_Click()
    With Sheets("19 RG PARC GLOBAL")
        If TextBox1 = "" And TextBox2 = "" Then Exit Sub
        If TextBox1 <> "" Then
        Set re = .Columns(4).Cells.Find(TextBox1)
        ElseIf TextBox2 <> "" Then
        Set re = .Columns(1).Cells.Find(TextBox2)
        End If
        If re Is Nothing Then Exit Sub
        lign = re.Row
        Me.EMAT8 = .Cells(lign, 1)
        Me.NomdeBapteme = .Cells(lign, 2)
        Me.ASM = .Cells(lign, 3)
        Me.AISM = .Cells(lign, 4)
        Me.SGL = .Cells(lign, 5)
        Me.CIE = .Cells(lign, 6)
        Me.Observation = .Cells(lign, 7)
        Me.GQGN = .Cells(lign, 8)
    End With
End Sub
Private Sub Modification_Click()
    L = lign
    With Sheets("19 RG PARC GLOBAL")
   'Pour placer le nouvel enregistrement à la première ligne de tableau non vide
        .Range("A" & L).Value = EMAT8    '
        .Range("B" & L).Value = NomdeBapteme    '
        .Range("C" & L).Value = ASM    '
        .Range("D" & L).Value = AISM    '
        .Range("E" & L).Value = SGL    '
        .Range("F" & L).Value = CIE    '
        .Range("G" & L).Value = Observation    '
        .Range("H" & L).Value = GQGN    '
    End With
End Sub

'Pour le bouton Quitter
Private Sub Quitter_Click()
    Unload Me
End Sub
Le 21/09/2017 à 09:57

Bonjour

Merci beaucoup cette fois sa fonctionne bien

Bonne réception.

Rechercher des sujets similaires à "probleme fonction modifier ligne vba"