XL 2016 message d'erreur

[phil107]

bonjour, j'ai ce message d'erreur qui apparait quelques fois

erreur d'exécution avec tout une suite de chiffre puis la méthode defaut de l'objet range a échoué

dans mon fichier lorsque je rentre un nouveau vin j'ai ce message d'erreur . merci d'avance pour l'aide que vous pourrez m"apporter

cordialement

 

[Rhysand]

Bonsoir à tous

J'ai apporté quelques modifications à votre code, j'ai trouvé plusieurs erreurs

Private Sub CommandButton1_Click()

Dim MyLastRow As Integer
Dim UserAnswer As VbMsgBoxResult
Dim tbl As ListObject
Dim ws As Worksheet
Dim sortcolumn As Range

UserAnswer = MsgBox("• Confirmez-vous cet ajout?", vbYesNo + vbQuestion, "Confirmation!")
    If CStr(UserAnswer) = CStr(False) Then Exit Sub
    If UserAnswer = vbCancel Then Exit Sub
    If UserAnswer = vbNo Then Exit Sub
    
Set ws = Application.ThisWorkbook.Worksheets("liste_vin")
  
With ws
    .Activate
    MyLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' ajout des données concernant le vin   Zone Jaune du tableau colonne 1 à 7
    .Cells(MyLastRow, 1) = CBB2.Value & " " & CBB3.Value & " " & CBB4.Value & " " & CBB6 ' Appellation + classement + climat + année
    .Cells(MyLastRow, 2) = CBB1.Value                                                    ' Région
    .Cells(MyLastRow, 3) = CBB5.Value                                                    ' Couleur
    .Cells(MyLastRow, 4) = CBB7.Value                                                    ' Nbre achat
    .Cells(MyLastRow, 5) = CBB11.Value                                                   ' Contenance
    .Cells(MyLastRow, 6) = CBB6.Value                                                    ' Millesime
    .Cells(MyLastRow, 7) = CBB9.Value & "." & CBB10.Value                   ' Rangement
    .Cells(MyLastRow, 18) = CBB8.Value                                                   ' Région
'  ajout des données concernant le domaine    Zone rose  du tableau colonne 8 à 12
    .Cells(MyLastRow, 8) = TxtDomaine.Value                                              ' Nom du domaine
    .Cells(MyLastRow, 9) = TxtAdresse & " " & TxtCp.Value & " " & TxtVille.Value         ' adresse
    .Cells(MyLastRow, 10) = TxtTel.Value                                                 'Telephone
    .Cells(MyLastRow, 11) = TxtMail.Value                                                ' Mail
    .Cells(MyLastRow, 12) = TxtInternet.Value                                            ' internet

' ajout des donnees concernant les caracteristiques du vin
    .Cells(MyLastRow, 13) = TxtInformation.Value
    .Cells(MyLastRow, 14) = TxtQuemangerAvec.Value
    .Cells(MyLastRow, 15) = TxtCaracteristique.Value
    .Cells(MyLastRow, 16) = TxtServiceVin.Value
    .Cells(MyLastRow, 17) = TxtConservation.Value
End With

'Classement des vins par annee
Set tbl = ws.ListObjects("Tableau2")
Set sortcolumn = Range("Tableau2[Millesime]")

With tbl.Sort
   .SortFields.Clear
   .SortFields.Add Key:=sortcolumn, SortOn:=xlSortOnValues, Order:=xlAscending
   .Header = xlYes
   .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
   .Apply
End With

If Not sortcolumn Is Nothing Then Set sortcolumn = Nothing
If Not tbl Is Nothing Then Set tbl = Nothing
If Not ws Is Nothing Then Set ws = Nothing

End Sub

J'espère aider

 

[laurent950]

Bonsoir,
J'ai fait le même constat beaucoup d'erreur que vous avez repris. Il faut Ajouter Value à CB6 sur cette cette ligne.

.Cells(MyLastRow, 1) = CBB2.Value & " " & CBB3.Value & " " & CBB4.Value & " " & CBB6

CBB6.Value

cdt

 

[Rhysand]

laurent950

merci beaucoup pour la correction, j'allais rectifier, car j'ai vu la même chose. c'est mon erreur

 

[phil107]

merci pour votre aide mais il y a un probléme. Des que je veux insérer un nouveau vin dans ma liste . il ne s'affiche pas à la suite des autres
Merci encore pour l'aide

 

[Rhysand]

Bonjour à tous

votre feuille de calcul contenait des erreurs, je ne sais pas comment spécifier, mais j'ai dû supprimer toute mise en forme car il n'était pas possible d'insérer une nouvelle ligne dans le tableau

mon conseil est avant de copier les codes suivants que je vais mettre, copiez les données de la feuille de calcul " liste_vin " dans une nouvelle feuille de calcul, mais collez simplement les valeurs, sans conditions ni format

supprimer l'ancienne feuille de calcul et renommer la nouvelle feuille de calcul en "liste_vin"

sélectionnez les données pour créer la table et renommez la table avec "Tableau2"

ajouter un module standard, et copiez les codes suivants et collez-les

Public Function TableExists(tableName As String, ws As Worksheet) As Boolean ' DÉTERMINER SI LE NOM DE LA TABLE EXISTE
    On Error GoTo TableExists_Error
    If ws.ListObjects(tableName).Name = vbNullString Then
    End If
   
    TableExists = True
   
    On Error GoTo 0
    Exit Function
   
TableExists_Error:
        TableExists = False
End Function

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean ' Déterminer si un nom de feuille de calcul existe dans ce classeur
    On Error Resume Next
    WorksheetExists = (ThisWorkbook.Sheets(WorksheetName).Name <> "")
    On Error GoTo 0
End Function

remplacez le code que vous avez dans CommandButton1_Click par ce qui suit

Private Sub CommandButton1_Click()
    If Not WorksheetExists("liste_vin") Then ' Déterminer si un nom de feuille de calcul existe dans ce classeur (MACRO)
        MsgBox "Erreur critique:" & vbCrLf & vbCrLf & "• Base de données introuvable!", vbCritical, "Information!"
        Exit Sub
    End If
   
    Dim ws As Worksheet
    Dim tableName As String
    Dim xAdd(17)
    Dim UserAnswer As VbMsgBoxResult
    Dim tbl As ListObject
    Dim sortcolumn As Range
   
    UserAnswer = MsgBox("• Confirmez-vous cet ajout?", vbYesNo + vbQuestion, "Confirmation!")
        If CStr(UserAnswer) = CStr(False) Then Exit Sub
        If UserAnswer = vbCancel Then Exit Sub
        If UserAnswer = vbNo Then Exit Sub
   
    tableName = "Tableau2"
    Set ws = Application.ThisWorkbook.Worksheets("liste_vin")
   
    If Not TableExists(tableName, ws) Then '  table exist (MACRO)
        MsgBox "Accès refusé: " & vbCrLf & vbCrLf & " • Base de données non trouvée, vérifiez si elle a déjà été créée! ", vbCritical, "Information!"
        If Not ws Is Nothing Then Set ws = Nothing
        Exit Sub
    End If
   
    ' ajout des données concernant le vin   Zone Jaune du tableau colonne 1 à 7
    xAdd(0) = Me.CBB2.Value & " " & Me.CBB3.Value & " " & Me.CBB4.Value & " " & Me.CBB6.Value   ' Appellation + classement + climat + année
    xAdd(1) = Me.CBB1.Value                                                                     ' Région
    xAdd(2) = Me.CBB5.Value                                                                     ' Couleur
    xAdd(3) = Me.CBB7.Value                                                                     ' Nbre achat
    xAdd(4) = Me.CBB11.Value                                                                    ' Contenance
    xAdd(5) = CBB6.Value                                                                        ' Millesime
    xAdd(6) = Me.CBB9.Value & "." & Me.CBB10.Value                                              ' Rangement
    xAdd(17) = Me.CBB8.Value                                                                    ' Région
    '  ajout des données concernant le domaine    Zone rose  du tableau colonne 8 à 12
    xAdd(7) = Me.TxtDomaine.Value                                                               ' Nom du domaine
    xAdd(8) = Me.TxtAdresse.Value & " " & Me.TxtCp.Value & " " & Me.TxtVille.Value              ' adresse
    xAdd(9) = Me.TxtTel.Value                                                                   ' Telephone
    xAdd(10) = Me.TxtMail.Value                                                                 ' Mail
    xAdd(11) = Me.TxtInternet.Value                                                             ' internet
    ' ajout des donnees concernant les caracteristiques du vin
    xAdd(12) = Me.TxtInformation.Value
    xAdd(13) = Me.TxtQuemangerAvec.Value
    xAdd(14) = Me.TxtCaracteristique.Value
    xAdd(15) = Me.TxtServiceVin.Value
    xAdd(16) = Me.TxtConservation.Value
   
    AddRecordTableRow tableName, xAdd
   
    'Classement des vins par annee
    With ws.Range("Tableau2")
     LastRow = .Cells(.Rows.Count, 6).End(xlUp).Row
    End With
   
    Set tbl = ws.ListObjects("Tableau2")
    Set sortcolumn = ws.Range("F8:F" & LastRow)
   
    With tbl.Sort
       .SortFields.Clear
       .SortFields.Add Key:=sortcolumn, SortOn:=xlSortOnValues, Order:=xlAscending
       .Header = xlYes
       .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
       .Apply
    End With
   
    If Not sortcolumn Is Nothing Then Set sortcolumn = Nothing
    If Not tbl Is Nothing Then Set tbl = Nothing
    If Not ws Is Nothing Then Set ws = Nothing
End Sub

et collez le code suivant juste après l'événement CommandButton1_Click

Private Sub AddRecordTableRow(XtableName As String, values() As Variant)
    Dim ws As Worksheet
    Dim table As ListObject
    Dim col As Integer
    Dim LastRow As Integer, lastcol As Integer
   
    Set ws = Application.ThisWorkbook.Worksheets("liste_vin")
   
    With ws
        .Activate
        Set table = .ListObjects.Item(XtableName)
       
        With .Range("Tableau2")
            LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
            Debug.Print LastRow
            lastcol = .Columns.Count
            Debug.Print lastcol
        End With
   
        If table.ListRows.Count > 0 Then
            For col = 1 To lastcol
                If Trim(CStr(.Cells(LastRow, col).Value)) <> "" Then
                    table.ListRows.Add AlwaysInsert:=True
                    Exit For
                End If
            Next col
        Else
            table.ListRows.Add AlwaysInsert:=True
        End If
   
        LastRow = LastRow + 1
       
        For col = 1 To lastcol
            If col <= UBound(values) + 1 Then .Cells(LastRow, col) = values(col - 1)
        Next col
   
    End With
   
    MsgBox "• Nouveau record de vin ajouté!", vbInformation, "Information!"
   
    If Not table Is Nothing Then Set table = Nothing
    If Not ws Is Nothing Then Set ws = Nothing
End Sub

J'ai fait plusieurs tests, et tout fonctionne parfaitement


J'espère aider

 

[phil107]

bonjour. je suis sincèrement désolé je pensais avoir suivi vos conseils mais j'ai toujours des problèmes . pourrez vous regarder sur le fichier ou j'ai péché . Merci encore une fois pour votre aide

 

[Rhysand]

Bonsoir à tous


vous avez une erreur, elle est marquée en rouge, vous aviez:
tableName = "Tableau2"
au lieu d'avoir
tableName = "Tableau22"


Private Sub CommandButton1_Click()
If Not WorksheetExists("liste_vin") Then ' Déterminer si un nom de feuille de calcul existe dans ce classeur (MACRO)
MsgBox "Erreur critique:" & vbCrLf & vbCrLf & "• Base de données introuvable!", vbCritical, "Information!"
Exit Sub
End If

Dim ws As Worksheet
Dim tableName As String
Dim xAdd(17)
Dim UserAnswer As VbMsgBoxResult
Dim tbl As ListObject
Dim sortcolumn As Range

UserAnswer = MsgBox("• Confirmez-vous cet ajout?", vbYesNo + vbQuestion, "Confirmation!")
If CStr(UserAnswer) = CStr(False) Then Exit Sub
If UserAnswer = vbCancel Then Exit Sub
If UserAnswer = vbNo Then Exit Sub

tableName = "Tableau22"
Set ws = Application.ThisWorkbook.Worksheets("liste_vin")
...

Je viens de corriger cette erreur et cela fonctionne

J'espère aider

 

[phil107]

je vous remercie très sincèrement pour l'aide que vous m'avez apporté