Fiche dégustation

Merci Dan pour cette aide. Je ne savais pas traiter un tableau structuré en VBA maintenant c'est bon (je suis quand même un peu débutant dans le domaine). J'ai adopté le fichier car il est évidemment plus rapide que le mien.

Bonjour Alain,
Un petit travail pour toi dans la page Tableauanalyse.

Bonjour fcyspm30,

Voila le classement pour moi, tu peux le modifier juste pour comparer et je vais aussi le faire classer par mon épouse afin de comparer aussi nos choix.

Je te souhaite un excellente journée.

Alain

Bonjour,

J'ai juste une petite remarque au sujet des tableaux structurés :

Dans les tableaux au format structuré, vous ne devez jamais préparer vos tableaux à l'avance. Donc vous ne devez jamais avoir de lignes vides après la dernière ligne complétée ou dans le tableau.
Lors de l'ajout de données dans les feuilles, il vous suffit d'ajouter après la dernière ligne (manuellement ou par code VBA). Les tableaux s'adaptent automatiquement et leur nom aussi.
Si vous supprimez une ligne manuellement, sélectionnez une cellule sur la ligne, puis click droite et choisir "Supprimer" et "Lignes de tableau". Vous devez toujours voir cette info "Lignes de tableau". Le cas échéant c'est que votre tableau n'est pas au bon format.

Sinon le fichier prend forme...

Cordialement

Bonjour,

Si je comprends bien le fait de supprimer les lignes de cette façon cela redimentionne automatiquement le tableau. C'est bien noté dans ma mémoire.

Si je comprends bien le fait de supprimer les lignes de cette façon cela redimentionne automatiquement le tableau.

Exact.
Comme le fait d'ajouter. Dans le fichier Desgustation3 posté, faites le test suivant :
- Positionnez-vous juste en dessous de la dernière ligne. Donc un cellule A6
- Ajoutez un nom

Vous allez voir que le tableau prend directement en compte la nouvelle information en créant une ligne

Dans ce même fichier,
1. pour supprimer une ligne vide (la ligne 2 par exemple) :
- Sélectionnez A2 à V2
- Click droite, puis Choisir Supprimer --> Lignes de tableau.

2. Pour supprimez toutes les données
- sélectionnez A2 à V5
- click droite --> Supprimer --> Lignes de tableau
Vous verrez que la ligne 2 reste sans données mais le tableau structuré la voit.

Cordialement

Bonjour Alain et le forum
Voici la dernière mouture. Je l'ai faite pour quatre gouteurs mais on peut allonger la liste. La fiche de synthèse (celle qui sera enregistrée) ne devra pas être modifiée. Tout se passe dans le tableau d'analyse. Il suffit de cliquer dans chaque critère renseigné par les gouteurs. A tester sous toutes les coutures.

Bonsoir fcyspm30,

Je viens de le télécharger le fichier, je reviens vers toi rapidement.

Merci pour ton aide.

Alain

Bonjour,

Il y avait quelques erreurs que j'ai rectifiées. Ca ira mieux avec ce fichier. Dans le cas d'une case cliquée un peu rapidement on peut l'annuler en recliquant dessus.

Bonjour fcyspm30,

J'ai regardé le fichier, testé et mis quelques annotations dessus. J'ai arrêté le test pour ne pas me dissiper.

Jene comprends pas tout mais ça s'annonce super.

Alain

Bonjour

En principe cela devrait être la dernière mouture. Qand tu ouvres le fichier tu es sur tableauanalyse. Tu entres le nom du vin, l'appellation, le millésime, la couleur et ensuite tu cliques sur les critères dans les zones blanches qui doivent s'allumer en vert pour ne pas en oublier. Si tu t'es trompé sur un critère tu re cliques dessus pour annuler la dernière entrée. Une fois que tous les critères du gouteur1 sont entrés tu passe au gouteur2 etc,. Quand les critères de tous les gouteurs ont été renseignés tu retournes sur la fiche récapitulative qui aura été renseignée automatiquement grâce aux calcul des informations du tableau analyse. A ce moment là tu n'auras qu'à appuyer sur le bouton "Enregistrer la fiche" et c'est tout. Mais prend bien le dernier fichier que je t'envoie.

Oui c'est bien ça. En revanche il faut me dire combien tu voudrais de gouteurs. Un spécialiste du VBA aurait certainement fait différemment mais j'ai voulu ne pas trop m'éloigner de ta fiche de dégustation initiale. Et de plus le VBA n'est pas mon fort je suis très limité dans ce domaine..

Pour les gouteurs je pense que pour assurer il en faut mini 10, le panel doit être parlant.

Tu n'est pas un spécialiste du VBA mais je dois reconnaitre que tu fais du bon travail.

Voilà avec 10 gouteurs

Je me suis aperçu qu'il y avait un petit problème de notation. Je verifie et rectifie.

Voila c'est rectifié

Edit modo Dan : 1ier fichier supprimé suite à problème de notation

Bonjour,

J'ai passé un peu de temps à regarder le fichier.
Le premier code dans la feuille Tableauanalyse peut être remplacé par celui-ci

Dim stpevt As Boolean
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If stpevt = True Then Exit Sub

If Not Application.Intersect(Target, Range("B6:AA16,B20:AA30,B34:AA44,B48:AA58,B62:AA72,B76:AA86,B90:AA100,B104:AA114,B118:AA128,B132:AA142")) Is Nothing Then

    li = Target.Row
    co = Target.Column
    stpevt = True

    If Target.Interior.ColorIndex <> 4 Then
        Target.Interior.ColorIndex = 4
            If co < 16 Then
                Range("N" & li) = Target.Offset(0, 1).value
                Range("P" & li) = co / 2
                Range("A" & li).Select
            Else
                Range("AB" & li) = Target.value
                Range("A" & li).Select
            End If
    Else
        Target.Interior.ColorIndex = xlNone
            If co < 16 Then
                Range("N" & li).ClearContents
                Range("P" & li).ClearContents
            Else
                Range("AB" & li).ClearContents
                Range("AC" & li).ClearContents
            End If
    End If
End If
Call calcul
stpevt = False
End Sub

Faites un petit test pour voir si cela fonctionne toujours comme vous voulez.
Attention que la variable stpevt doit être la première instruction dans cette feuille

Si ok, je peux vous donner le code Calcul simplifié (tout au moins avec moins de lignes).

Pour fcyspm30 : vous avez deux fichiers dans votre dernier post. Je peux supprimer le premier que vous avez posté et qui comporte une erreur.

Cordialement

Bonjour Dan,

Oui je veux bien retirer ce fichier. Pour le code je le teste et j'envoie un retour

Re-bonjour,

Oui ça fonctionne parfaitement. Merci Dan.
Pour Alain voici le fichier avec le code de Dan et quelques modifications de confort.

Pour le moment toutes les données ne sont pas enregistrées dans la BDD je vais le règler rapidement. Dans l'attente je réfléchis pour rechercher un vin dans une liste basée sur la 3ème colonne de la BDD (nom+millésime) et de récupérer les données afférente à la ligne trouvée pour les afficher dans la fiche de synthèse. Comme la BDD est un tableau structuré je n'ai pas toutes les infos pour créer mon code. Je fais mes recherches et dès que c'est prêt je propose. Et j'aimerais si possible que Dan me corrige ce future code.

Ok je vois que cela fonctionne.
Voici donc le code Calcul à tester comme je vous avais écrit avant.

Sub calcul()
Dim sf As Worksheet, st As Worksheet
Set sf = ThisWorkbook.Worksheets("Fiches")
Set st = ThisWorkbook.Worksheets("Tableauanalyse")
On Error Resume Next
'Positions
Dim plage As Range
Dim i As Byte, j As Byte

j = 6
For i = 6 To 19
    Select Case i
        Case Is = 10: i = 12
        Case Is = 13: i = 14
    End Select

    Set plage = Union(Range("P" & j), Range("P" & j + 14), Range("P" & j + 28), Range("P" & j + 42), Range("P" & j + 56), Range("P" & j + 70), Range("P" & j + 84), Range("P" & j + 98), Range("P" & j + 102), Range("P" & j + 126))
    sf.Range("Q" & i) = Round(Application.Sum(plage) / Application.WorksheetFunction.Count(plage))
    j = j + 1
Next i

j = 6
For i = 26 To 34 Step 4

    Set plage = Union(Range("AB" & j), Range("AB" & j + 14), Range("AB" & j + 28), Range("AB" & j + 42), Range("AB" & j + 56), Range("AB" & j + 70), Range("AB" & j + 84), Range("AB" & j + 98), Range("AB" & j + 102), Range("AB" & j + 126))
    sf.Range("Q" & i) = Round(Application.Sum(plage) / Application.WorksheetFunction.Count(plage))
    j = j + 1

Next i

'notes
Dim X As Byte

j = 6
For i = 6 To 19
    Select Case i
        Case Is = 10: i = 12
        Case Is = 13: i = 14
    End Select

    Select Case j
        Case Is = 6, 8, 12: X = 5 * 10
        Case Is = 7, 14, 15: X = 1
        Case Is = 9, 16: X = 6 * 10
        Case Is = 10: X = 2 * 10
        Case Is = 11, 13: X = 4 * 10
    End Select
    Set plage = Union(Range("N" & j), Range("N" & j + 14), Range("N" & j + 28), Range("N" & j + 42), Range("N" & j + 56), Range("N" & j + 70), Range("N" & j + 84), Range("N" & j + 98), Range("N" & j + 102), Range("N" & j + 126))
    sf.Range("R" & i) = Round(Application.Sum(plage) / Application.WorksheetFunction.Count(plage)) / X
    j = j + 1
Next i

j = 6
For i = 26 To 34 Step 4

    Set plage = Union(Range("AB" & j), Range("AB" & j + 14), Range("AB" & j + 28), Range("AB" & j + 42), Range("AB" & j + 56), Range("AB" & j + 70), Range("AB" & j + 84), Range("AB" & j + 98), Range("AB" & j + 102), Range("AB" & j + 126))
    sf.Range("R" & i) = Round(Application.Sum(plage) / Application.WorksheetFunction.Count(plage))
    j = j + 1

Next i

With sf
    .Range("P39") = Application.Sum(.Range("R6:R34")) / 14
    'Dénomination et arômes en bouche
    .Range("K2") = Range("B1")
    .Range("K3") = Range("B2")
    .Range("K4") = Range("B3")
    .Range("O3") = Range("B4")
    .Range("H22") = Range("B17") & " " & Range("B31") & " " & Range("B45") & " " & Range("B59") & Range("B73") & " " & Range("B87") & " " & Range("B101") & " " & Range("B115") & Range("B129") & " " & Range("B143")
End With
End Sub

Le On error resume next est laissé mais je ne vois pas l'utilité

Autre point : J'ai vu que vous aviez dupliquer le mot Application dans les formules. Pourquoi ?

Re

Evidemment avec mon esprit de débutant pragmatique je ne voyais pas les choses de cette façon. Ceci dit mon code fonctionnait dès lors que j'avais mis ma petite ligne

On Error Resume Next

sinon j'avais des blocages.
Je 'nai pas encore testé mais je vais essayer de décortiquer toutes ces boucles qui me semblent effectivement mieux adaptées.