Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 message d'erreur

phil107

XLDnaute Nouveau
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
 

Pièces jointes

  • Ma cave version nov 2020.xlsm
    522.1 KB · Affichages: 15

Rhysand

XLDnaute Junior
Bonsoir à tous

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



VB:
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
 

phil107

XLDnaute Nouveau
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
 

Pièces jointes

  • Ma cave version nov 2020v1.xlsm
    522.3 KB · Affichages: 6

Rhysand

XLDnaute Junior
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


VB:
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

VB:
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

VB:
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

XLDnaute Nouveau
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
 

Pièces jointes

  • Ma cave version nov 2020v2 (2).xlsm
    524.4 KB · Affichages: 4

Rhysand

XLDnaute Junior
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
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…