VB Excel Comptabiliser selon des conditions

Résolu
Rallyecox -  
 Rallyecox -
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>

5 réponses

  1.
    michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    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
    1. Rallyecox
       
      Merci de vous intéresser au problème, j'ai posté le fichier à l'adresse :
      http://cjoint.com/?ALDoIT1hruy
      0
  2. Rallyecox
     
    Le classeur se trouve a : http://cjoint.com/?ALDoIT1hruy

    Merci de vous intéresser au problème
    0
  3. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    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
    1. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      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
  4. Rallyecox
     
    Ok Michel, j'essaye de suite... je reviens.
    0

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

    Posez votre question
  6. Rallyecox
     
    Merci, milles fois. Cela fonctionne super bien !
    0