XL 2010 Pb macro (valider ou non cellule)

M

MelissaJoubert

XLDnaute Junior
Bonjour à tous !!

J'ai à nouveau besoin de votre aide pour la création d'un macro :D

Je vous envoi mon fichier excel pour que vous compreniez mieux :)
(je vous conseil de l'ouvrir avant de lire la suite sinon vous allez rien comprendre je pense )

On va se préoccuper seulement de l'onglet "feuil1".
J'aimerai que lorsque je coche la case, le PU dans le tableau correspondant ne se compte pas dans le PU moyen "I6".

Exemple:
Si je coche la case du premier tableau "C14", le PU de la case " I13" ne va pas se comptabilisé dans mon PU moyen situé en I6.

J'espere que vous comprenez mon problème :p

Par contre en I6 j'ai mis une formule simple mais il me faudrait également un macro pour toujours m'ajouter les données rempli dans les cases PU car dans ma page je vais rajouter des petits tableaux donc il faudrait que mes prix s'ajoute à chanque fois.

Exemple : Si j'ajoute un tableau en cliquant sur "ajouter", quand je vais remplir ma case PU, la valeur que je vais rentrer doit être comptabilisé dans mon PU moyen automatiquement.

Merci à vous j'ai vraiment besoin de votre aide :) !!
 

Pièces jointes

  • test3.xlsm
    58.8 KB · Affichages: 32
Trier par date Trier par votes
vgendron

vgendron

XLDnaute Barbatruc
dans le code de la feuille
il faut modifier les deux lignes avec union..
c'est le code qui colorie en gris. au lieu de les laisser en blanc..


VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False

If Target.Count = 1 And Target.Column = 2 Then 'colonne 2 car colonne B
    If LCase(Target.Value) = "affaire" Then 'nom de la case affaire
        maligne = Target.Row 'ligne active
        Rows(maligne + 2 & ":" & maligne + 10).Copy 'copie du tableau
        Rows(maligne + 11 & ":" & maligne + 19).Insert shift:=xlDown 'colle au dessus
        Application.CutCopyMode = False
        Range("D" & maligne + 2).Resize(7, 15).Select
        Selection.ClearContents 'on efface le petit tableau qui vient d'etre inséré
        'et on réécrit la formule en colonne Q
        formule = "=P" & maligne + 5 & "*O" & maligne + 5
        Range("Q" & maligne + 3).FormulaLocal = formule
        'et on réécrit la formule en colonne N
        formule1 = "=$N$" & maligne + 0
        Range("N" & maligne + 3).FormulaLocal = formule1
               
        'décale sélection d'une ligne
        Range(Target.Address).Offset(1, 0).Select
    End If
    If Target = "." Then 'si je vois ça(.) et que je clique dessus
        Target = ".." 'alors on remplace par (..) et on change la couleur avec la ligne en dessous
        Union(Target.Offset(0, 3), Target.Offset(-3, 4).Resize(2, 5), Target.Offset(3, 4).Resize(1, 5), Target.Offset(0, 11).Resize(, 2), Target.Offset(-2, 13).Resize(, 2), Target.Offset(2, 13).Resize(, 2), Target.Offset(0, 15).Resize(, 2)).Select
        Selection.Interior.Color = RGB(234, 234, 234)
        Target.Offset(1, 0).Select
        Call calculmoyenne(Cells(Target.Row - 1, 16))
    ElseIf Target = ".." Then 'si je vois ça(..) et je clique dessus
        Target = "." 'alors on remplace par (.) et on change la couleur avec la ligne en dessous
        Union(Target.Offset(0, 3), Target.Offset(-3, 4).Resize(2, 5), Target.Offset(3, 4).Resize(1, 5), Target.Offset(0, 11).Resize(, 2), Target.Offset(-2, 13).Resize(, 2), Target.Offset(2, 13).Resize(, 2), Target.Offset(0, 15).Resize(, 2)).Select
        Selection.Interior.Color = RGB(255, 254, 140) 'selectionner chaque case a changer de couleur (ici jaune)
        Target.Offset(1, 0).Select
        Call calculmoyenne(Cells(Target.Row - 1, 16))
    End If
    If Target = "image" Then
        Target.Offset(0, 10).Select
        ad = Selection.Address
        ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image")
        If ficimg <> False Then
            ActiveSheet.Pictures.Insert(ficimg).Select
            With Selection.ShapeRange
                .LockAspectRatio = False        ' proportions d'origine lorsque vous la redimensionnez
                .Top = Range(ad).Top           ' haut de la cellule
                .Left = Range(ad).Left          ' gauche de la cellule
                .Height = Range(ad).Height  ' hauteur de la cellule
                .Width = Range(ad).Width ' largeur de la cellule
            End With
            With Selection
                .PrintObject = True             ' l'objet est imprimé en même temps que le document
                .Placement = xlMoveAndSize      ' manière dont l'objet est lié aux cellules
            End With
        End If
    End If
End If

Application.EnableEvents = True
   
End Sub

après. ce qui me gène, c'est qu'à chaque fois que tu postes un nouveau fichier, beaucoup de choses ont changé..
ex: le bloc de "référence". celui qui est copié collé à chaque clic sur "InsererBloc" n'est PLUS masqué..

les macros sont modifiées et plus aux memes places dans les modules.
les feuilles changent de nom. et j'ai toujours l'impression que tu ne donnes pas l'ensemble des codes.
ex: tu avais un autre post dans lequel tu demandais de pouvoir créer des feuilles en fonction du contenu de la feuille "Données"... la . je ne vois rien..

bref, c'est perturbant, et je ne peux meme pas te garantir que les ajustements que je te propose ne vont pas perturber le reste..
 
Vote positif 0 Vote négatif
M

MelissaJoubert

XLDnaute Junior
vgendron à dit:
après. ce qui me gène, c'est qu'à chaque fois que tu postes un nouveau fichier, beaucoup de choses ont changé..
ex: le bloc de "référence". celui qui est copié collé à chaque clic sur "InsererBloc" n'est PLUS masqué..

les macros sont modifiées et plus aux memes places dans les modules.
les feuilles changent de nom. et j'ai toujours l'impression que tu ne donnes pas l'ensemble des codes.
ex: tu avais un autre post dans lequel tu demandais de pouvoir créer des feuilles en fonction du contenu de la feuille "Données"... la . je ne vois rien..

bref, c'est perturbant, et je ne peux meme pas te garantir que les ajustements que je te propose ne vont pas perturber le reste..
Cliquez pour agrandir...

Oui je suis désolé mais je met en forme mon fichier au fur et a mesure et donc il y a toujours des changement !! Mais tu m'a beaucoup aidé et la c'est le truc final et je me rend compte que parfois il y a des petit détail qui ne marche pas !!

vgendron à dit:
dans le code de la feuille
il faut modifier les deux lignes avec union..
c'est le code qui colorie en gris. au lieu de les laisser en blanc..
Cliquez pour agrandir...
En effet tu a raison j'ai rajouté une ligne pour dire que je la veux blanche mais il y a quand même des beug :(
 
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
C'est ici que ca bug

VB: 
'Recherche du début des tableaux avec l'entete "PU" (Utile pour se repérer pour placer les résultats ensuite)
While Cells(debut, Target.Column) <> "PU" And Cells(debut, Target.Column) <> "Qté"
    debut = debut - 1
Wend
debut = debut + 6

'On rebondit de tableau en tableau jusqu'à tomber sur du gris qui est présent dans un nouveau bloc
While Cells(fin + 9, Target.Column).Interior.Color = RGB(234, 234, 234)
    fin = fin + 9
Wend

est ce toi qui a ajouté le test : And Cells(debut, Target.Column) <> "Qté"
si c'est moi. je ne vois pas, ou plus pourquoi

pour la recherche du dernier tableau.. : plusieurs choses
1) While Cells(fin + 9, Target.Column).Interior.Color = RGB(234, 234, 234)
tant que la celulle est grise on continue. sauf que les cellules sont blanches..
il faudrait plutot. tant qu'on est PAS sur une celulle grise. laquelle est synonyme de nouveau bloc
2) du coup.. si on est déjà dans le dernier bloc..
on ne trouvera jamais le dernier tableau

il faut donc ajouter un test sur fin.. --> on peut augmenter fin (fin+9) Seulement si fin reste < la dernière ligne de toute la feuille
 
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
Essaie ceci
VB: 
Sub calculmoyenne(Target As Range)
Dim debut As Integer
Dim fin As Integer
Dim somme As Double
Dim sommeq As Double
Dim ref As Integer
Dim min As Double
Dim max As Double
Dim nbreaff As Integer
Dim quantite As Integer

'MsgBox Target.Address
somme = 0
sommeq = 0
max = 0
nbreaff = 0
debut = Target.Row
fin = debut
ref = 16
MaxLigne = Range("P" & Rows.Count).End(xlUp).Row
'Recherche du début des tableaux avec l'entete "PU" (Utile pour se repérer pour placer les résultats ensuite)
While Cells(debut, Target.Column) <> "PU" 'And Cells(debut, Target.Column) <> "Qté"
    debut = debut - 1
Wend
debut = debut + 6

'On rebondit de tableau en tableau jusqu'à tomber sur du gris qui est présent dans un nouveau bloc
While Cells(fin + 9, Target.Column).Interior.Color <> RGB(234, 234, 234) And fin < MaxLigne
    fin = fin + 9
Wend

min = Cells(debut, ref)
For i = debut To fin Step 9
    'Si les deux cases contiennent quelque chose, on prend l'affaire en compte
    If Cells(i, ref) <> "" And Cells(i, ref - 1) <> "" And Cells(i - 1, ref).Interior.Color = RGB(255, 254, 140) Then
        nbreaff = nbreaff + 1 'Une affaire en plus
        somme = somme + Cells(i, ref) * Cells(i, ref - 1)
        sommeq = sommeq + Cells(i, ref - 1) 'Recupération PU
        quantite = quantite + Cells(i, ref - 1) 'Récupération quantité
       
        If Cells(i, ref) > max Then 'Test si la valeur est le max
            max = Cells(i, ref)
        End If
       
        If Cells(i, ref) < min Or min = 0 Then 'Test si la valeur est le min ou si min n'a pas été initialisé avec une valeur autre que 0
            min = Cells(i, ref)
        End If
    End If
Next i

If nbreaff > 0 Then
    Cells(debut - 18, ref) = somme / sommeq 'Saisie dans les bonne cases     si il y a des affaires prises en compte
    Cells(debut - 9, ref) = max
    Cells(debut - 10, ref) = min
    Cells(debut - 9, ref + 2) = quantite / nbreaff
    Cells(debut - 10, ref + 2) = nbreaff
Else
    Cells(debut - 18, ref) = "" 'Saisie dans les bonne cases
    Cells(debut - 9, ref) = ""
    Cells(debut - 10, ref) = ""
    Cells(debut - 9, ref + 2) = ""
    Cells(debut - 10, ref + 2) = ""
End If
End Sub
 
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
ET correction de l'évènement change
qui ne lancait pas la MAJ du calcul

VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
'MsgBox Target.Interior.Color

If Target.Interior.ColorIndex = xlNone And (Target.Column = 16 Or Target.Column = 15) Then 'Pas mettre Target.count=1
    Call CalculMoyenne(Target)
End If

If Target.Column = 4 Then   'Colone D (ABSOLUMENT LAISSER EN SEPARER DE LA LIGNE SUIVANTE)
    If Target.MergeArea.Rows.Count = 7 Then        'et une cellule qui est la fusion de 7 cellule
        Set cell = Sheets("Données").Columns(2).Cells.Find(Target, LookAt:=xlWhole)
        If cell Is Nothing Then
            MsgBox ("Pas de numero d'affaire trouvé dans les données")
            Cells(Target.Row, Target.Column + 2) = ""
            Cells(Target.Row, Target.Column + 3) = ""
            Cells(Target.Row, Target.Column + 4) = ""
            Cells(Target.Row, Target.Column + 5) = ""
            Cells(Target.Row, Target.Column + 7) = ""
            Cells(Target.Row, Target.Column + 8) = ""
            Cells(Target.Row, Target.Column + 9) = ""
            Cells(Target.Row, Target.Column + 14) = ""
        Else
            Cells(Target.Row, Target.Column + 2) = Sheets("Données").Cells(cell.Row, 3)
            Cells(Target.Row, Target.Column + 3) = Sheets("Données").Cells(cell.Row, 4)
            Cells(Target.Row, Target.Column + 4) = Sheets("Données").Cells(cell.Row, 5)
            Cells(Target.Row, Target.Column + 5) = Sheets("Données").Cells(cell.Row, 6)
            Cells(Target.Row, Target.Column + 7) = Sheets("Données").Cells(cell.Row, 7)
            Cells(Target.Row, Target.Column + 8) = Sheets("Données").Cells(cell.Row, 8)
            Cells(Target.Row, Target.Column + 9) = Sheets("Données").Cells(cell.Row, 10)
            Cells(Target.Row, Target.Column + 14) = Sheets("Données").Cells(cell.Row, 9)
        End If
    End If
End If
End Sub

Voir PJ pour l'ensemble des modifs
 

Pièces jointes

  • FINAL - SOMMAIRE REV2.xlsm
    82.3 KB · Affichages: 32
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
Question pour anticiper...
je vois dans le fichier qu'il y a tout un tas de feuilles vierges 101 200 - 101 300......
je présume que dans un proche avenir elles ressembleront toutes à la feuille 101 100
et donc.. qu'il faudra qu'elles réagissent de la meme manière aux clics sur les différentes cellules (image, affaire, ., .. etc etc..) ??

je pense qu'il va donc falloir adapter le code pour éviter d'avoir à recopier TOUT le code autant de fois que de feuilles.. sous peine d'avoir un fichier lourd... très lourd...
 
Vote positif 0 Vote négatif

Discussions similaires

L
  • Question
Microsoft 365 Erreur "Excel a manqué de ressources..." avec macro
Réponses
3
Affichages
352
AtTheOne
AtTheOne
D
  • Question
XL 2019 Aide pour formule ou code
Réponses
2
Affichages
167
Dimitri13
D
Icefedor
  • Résolu(e)
XL 2021 Case à cocher afin d'insérer des lignes dans une autre feuille
Réponses
2
Affichages
438
Icefedor
Icefedor
C
  • Résolu(e)
Microsoft 365 SommeSi VBA avec integration de variable
Réponses
5
Affichages
301
danielco
D
Jean Marc DALPHRASE
  • Question
XL 2016 Insertion automatique d'une photo dans une cellule
Réponses
5
Affichages
275
Jean Marc DALPHRASE
Jean Marc DALPHRASE
C
  • Question
Autres Protection de ligne et colonneEe
Réponses
5
Affichages
177
clo91
C
C
  • Résolu(e)
XL 2021 Effacement de données.
Réponses
5
Affichages
279
Constantin
C
M
  • Résolu(e)
Microsoft 365 Mise en forme conditionnelle: ne pas colorer une cellule non renseignée
Réponses
6
Affichages
277
Mouss3710
M
B
  • Question
XL 2016 Exécution macro à l'ouverture de fichier
Réponses
3
Affichages
310
crocrocro
C
C
  • Question
XL 2016 Lier la 1re colonne du tableau 1 avec la 1re colonne du tableau 2
Réponses
7
Affichages
428
Cousinhub
Cousinhub

Membres actuellement en ligne

20 membres et 324 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 231
Messages
2 086 438
Membres
103 209
dernier inscrit
MIKA33260