Sujet Précédent Sujet Suivant

VB Excel Comptabiliser selon des conditions

Résolu/Fermé
Rallyecox - 29 déc. 2011 à 12:15
 Rallyecox - 29 déc. 2011 à 18:05
Bonjour,
Je fais un petit programme sous excel pour situer les forces en présences pour une assemblée générale élective. A partir d'une feuille de" donnees" je colorie une carte de france avec une macro selon plusieurs conditions. Je souhaiterais comptabiliser toutes les valeurs (nbre de licences et nbre de voix) de deux autres colonnes (6 et 7) qui correspondent aux différentes couleurs à établir dans un petit tableau situé sur la feuille "AG2012".En vous remerciant car je ne sais pas par ou commencer.
Voici la macro que j'ai utilisé pour remplir la carte de france.
Sub ColorMap()
Dim oSheet As Excel.Worksheet ' Feuille
Dim lLine As Long ' Numéro de ligne
Dim loShape As Shape ' Forme
Dim lColor As Long ' Couleur
' Feuille contenant la carte
Set oSheet = ThisWorkbook.Sheets("AG2012")
' Désactive le remplissage de la carte
oSheet.Shapes("CarteFrance").Fill.Visible = msoFalse
' Pour chaque ligne de CD
For lLine = Worksheets("Donnees").UsedRange.Row + 1 To Worksheets("Donnees").UsedRange.Row + Worksheets("Donnees").UsedRange.Rows.Count
' Couleur de remplissage
If Worksheets("Donnees").Cells(lLine, 9) = 0 And Worksheets("Donnees").Cells(lLine, 8) = 1 Then
lColor = vbRed
Else
If Worksheets("Donnees").Cells(lLine, 8) >= 0 And Worksheets("Donnees").Cells(lLine, 9) = 1 Then
lColor = vbBlue
Else
If Worksheets("Donnees").Cells(lLine, 8) = 0 And Worksheets("Donnees").Cells(lLine, 9) = 2 Then
lColor = vbGreen
Else
If Worksheets("Donnees").Cells(lLine, 8) = 1 And Worksheets("Donnees").Cells(lLine, 9) = 2 Then
lColor = vbYellow
Else
lColor = vbWhite
End If
End If
End If
End If
Next
End Sub



<config>Windows 7 / excel 2010</config>
A voir également:

5 réponses

Réponse 1 / 5
michel_m Messages postés 16602 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 313
29 déc. 2011 à 13:23
Bonjour,

Sans voir le classeur, difficile de comprendre...
pour joindre une pièce
mettre le classeur sans données confidentielles en pièce jointe sur
https://www.cjoint.com/
et faire un clic droit sur le lien proposé puis "copier l'adresse du lien" et coller dans le message de réponse
0
Rallyecox
29 déc. 2011 à 14:38
Merci de vous intéresser au problème, j'ai posté le fichier à l'adresse :
http://cjoint.com/?ALDoIT1hruy
0
Réponse 2 / 5
Rallyecox
29 déc. 2011 à 14:40
Le classeur se trouve a : http://cjoint.com/?ALDoIT1hruy

Merci de vous intéresser au problème
0
Réponse 3 / 5
michel_m Messages postés 16602 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 313
29 déc. 2011 à 15:36
OK, merci
j'ai compris ceci
si par ex le département est rouge mettre en K16 le nbre de licences et en L16 le nbre de voix
je reviens d'ici 1 heure mais apparemment, pas trop de problèmes si j'ai vu juste.
0
michel_m Messages postés 16602 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 313
29 déc. 2011 à 17:07
Macro modifiée 
Sub ColorMap()
Dim oSheet As Excel.Worksheet ' Feuille
Dim lLine As Long ' Numéro de ligne
Dim loShape As Shape ' Forme
Dim lColor As Long ' Couleur
Dim T_totaux '  totaux licenciés et voix par couleur
Dim Rang As Byte 'rang de la couleur dans T_totaux

' Feuille contenant la carte
Set oSheet = ThisWorkbook.Sheets("AG2012")
' Désactive le remplissage de la carte
oSheet.Shapes("CarteFrance").Fill.Visible = msoFalse
' initialise le tableau des totaux
ReDim T_totaux(1 To 4, 1 To 2)

' Pour chaque ligne de CD
With Sheets("Donnees")
     For lLine = .UsedRange.Row + 1 To .UsedRange.Row + .UsedRange.Rows.Count
    ' Couleur de remplissage
    ' Bleu si New CD
    ' Rouge si CD Sortant
          If .Cells(lLine, 9) = 0 And .Cells(lLine, 8) = 1 Then
               lColor = vbRed
               rang = 3
          Else
               If .Cells(lLine, 8) >= 0 And .Cells(lLine, 9) = 1 Then
                     lColor = vbBlue
                    rang = 2
               Else
                     If .Cells(lLine, 8) = 0 And .Cells(lLine, 9) = 2 Then
                         lColor = vbGreen
                         rang = 1
                    Else
                         If .Cells(lLine, 8) = 1 And .Cells(lLine, 9) = 2 Then
                              lColor = vbYellow
                              rang = 4
                         Else
                              lColor = vbWhite
                         End If
                    End If
               End If
          End If
          
    'incrémente le tableau des totaux par couleur
    T_totaux(rang, 1) = .Cells(lLine, 6) + T_totaux(rang, 1)
     T_totaux(rang, 2) = .Cells(lLine, 7) + T_totaux(rang, 2)
  
    ' Parcours les départements de la carte
    For Each loShape In oSheet.Shapes("CarteFrance").GroupItems
        ' Si la forme loShape a pour nom la valeur de la première colonne (l'identifiant FR-XX)
        If loShape.Name = Worksheets("Donnees").Cells(lLine, 3) Then
            ' Réactive le remplissage de la forme
            loShape.Fill.Visible = True
            ' Type de remplissage = couleur unie
            loShape.Fill.Solid
            ' Pas de transparence
            loShape.Fill.Transparency = 0#
            ' Couleur de remplissage
            loShape.Fill.ForeColor.RGB = lColor
            ' La forme a été trouvée => on sort de la boucle
            Exit For
        End If
     Next
     Next
End With
oSheet.Range("K14:L17") = T_totaux
End Sub
0
Réponse 4 / 5
Rallyecox
29 déc. 2011 à 17:53
Ok Michel, j'essaye de suite... je reviens.
0

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
Réponse 5 / 5
Rallyecox
29 déc. 2011 à 18:05
Merci, milles fois. Cela fonctionne super bien !
0