XL 2010 Liste sans doublon ...plusieurs colonnes ...vba

Bulr6

XLDnaute Nouveau
Bonjour,
J'ai essayé de résumer au maximum ma question dans le titre.
J'ai parcouru le site de Mr Boisgontier et différents forum et pourtant je ne trouve pas l'once du début d'un code qui réussirait à répondre à l'ensemble de mes besoins.
Je suis passé par des formules matricielles mais le manque de "dynamise" (l'évolution de la plage) n'est pas idéal pour moi et quand je passe par un code je n'arrive à parcourir plusieurs colonne en ignorant les vides.

Je me suis permis de mettre un fichier "coquille" avec en rouge le résultat escompté mais pour être clair il faudrait :

Qu'en colonne M il me liste tous les intervenants de la colonne G:I (mon code ne prend que la colonne G)
Qu'en colonne N il me compte les occurences correspondantes ... idem il ne prend en compte que la colonne G

Merci à tout ceux qui prendront le temps de me lire
 

Pièces jointes

  • methodotestsansmacro2.xlsm
    24.7 KB · Affichages: 68

CISCO

XLDnaute Barbatruc
Bonjour

Une possibilité en pièce jointe, avec une formule matricielle, d'après une proposition de David84 donnée , les noms étant listés dans l'ordre alphabétique..

@ plus
 

Pièces jointes

  • methodotestsansmacro2.xlsm
    16.4 KB · Affichages: 100

PMO2

XLDnaute Accro
Bonjour,
Une piste avec macro.
1) Copiez le code suivant dans la fenêtre de code de la feuille concernée
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column >= 6 And Target.Column <= 9 Then Call SommeInterCours
End Sub
2) Copiez le code suivant dans un module standard
VB:
Const FIRST_CELL_DATA As String = "F3"  'La première cellule des data
Const CELL_INSCRIPTION As String = "M1" 'Le résultat s'inscrit à partir de cette cellule (à adapter)

Sub SommeInterCours(Optional dummy As Byte)
Dim S As Worksheet
Dim R As Range
Dim Formateurs As Variant
Dim Cours As Variant
Dim var As Variant
Dim T() 'Tableau dynamique
Dim LastLig&
Dim i&
Dim j&
Dim g&
Dim h&
'---
On Error GoTo Erreur
Application.EnableEvents = False
'--- Les titres ---
Set S = Sheets("Menus")
Formateurs = S.Range("A2:A" & S.[a2].End(xlDown).Row & "")
Cours = S.Range("B2:B" & S.[b2].End(xlDown).Row & "")
ReDim T(1 To UBound(Formateurs) + 1, 1 To UBound(Cours) + 2)
For i& = 2 To UBound(T, 1)
  T(i&, 1) = Formateurs(i& - 1, 1)
Next i&
For j& = 3 To UBound(T, 2)
  T(1, j&) = Cours(j& - 2, 1)
Next j&
'--- Les données ---
Set S = ActiveSheet
Set R = S.Range(FIRST_CELL_DATA)
If R = "" Then Exit Sub
LastLig& = S.[f65536].End(xlUp).Row
Set R = R.Resize(LastLig& - R.Row + 1, R.Columns.Count + 3)
var = R
'--- Algorithme ---
For i& = 1 To UBound(var, 1)
  For h& = 1 To UBound(Cours, 1)
    If var(i&, 1) = Cours(h&, 1) Then
      For j& = 1 To UBound(var, 2)
        For g& = 1 To UBound(Formateurs, 1)
          If var(i&, j&) = Formateurs(g&, 1) Then
            T(g& + 1, h& + 2) = T(g& + 1, h& + 2) + 1
            T(g& + 1, 2) = T(g& + 1, 2) + 1
          End If
        Next g&
      Next j&
    End If
  Next h&
Next i&
'--- Inscription ---
T(1, 1) = S.Name
T(1, 2) = "TOTAL cours"
Set R = S.Range(CELL_INSCRIPTION)
Set R = R.Resize(UBound(T, 1), UBound(T, 2))
R.ClearContents
R = T
'--- Pseudo traitement d'erreur ---
Erreur:
Application.EnableEvents = True
End Sub
 

Pièces jointes

  • methodotest_pmo.xlsm
    22.8 KB · Affichages: 84

Bulr6

XLDnaute Nouveau
Alors là je suis scotché PMO2 !!! Avec ton code je vais bien plus loin que ce que j'avais demandé et tu as mis en plein dans le mille dans le résultat final que j'envisageais!
J'étais au final sur le point de finir avec des sommeprod dans tous les sens le fichier ramait comme pas possible et là BIM !!! la solution miracle avec une rapidité d’exécution incroyable.
Je suis entrain d'adapter ça pour lancer cette opération sur différentes feuilles et inscrire tout ça dans une feuille bilan et ça tourne parfaitement.

Techniquement il s'agit de calculer des occurrences ... crois tu qu'il est possible d'avoir un rendu similaire mais pour faire justement un total mais cette fois des heures realisées
le même tableau mais avec la somme des heures / cours / intervenants

ex :
Septembre total heures TD1 TD2 etc
Anne 06:00 02:00 04:00
etc

Sinon encore un grand grand merci !
 

PMO2

XLDnaute Accro
Ce n'est pas bon comme vous faites.
Une seule procédure SommeInterCours est nécessaire dans un module standard, seules les feuilles ont besoin chacune de la même procédure événementielle Sub Worksheet_Change.
Vous inscrirez les résultats dans la feuille BILANS mais au lieu qu'ils soient en colonnes (septembre à partir de A et octobre à partir de M) ne serait-il pas plus judicieux de les mettre en lignes à partir de la colonne A (septembre en lignes 1 à 7 et octobre en lignes 9 à 15, la ligne libre 8 servirait d'espacement si vous voulez) ?
Prochainement je vous enverrai le code corrigé allant dans ce sens.
 

Bulr6

XLDnaute Nouveau
En effet, c'est nettement plus logique. J'ai opéré de la sorte car j'ai toujours à l'esprit que la liste des intervenant est variable et évolutive au cours de l'année ... C'était une sorte de "sécurité".mais j'imagine qu'il est tout à fait faisable d'insérer les tableaux les uns à la suite des autres ? Dans ce cas je pourrais tout à fait mettre la procédure similaire mais concernant le total heures dans la colonne L
EN fait pour cela si on garde un seul module comment en appelant cette procédure il serait possible de viser des "CELL_INSCRIPTION" variable et dépendante du tableau précédent ?

Je me suis permis d'ajouter une version visuellement plus proche du résultat final envisagé (feuille bilans en rouge)
 

Pièces jointes

  • methodotest.xlsm
    95.4 KB · Affichages: 46
Dernière édition:

PMO2

XLDnaute Accro
Bonjour,

Comme vous voulez obtenir une Synthèse de tous vos mois, une seule procédure (Sub BilanInterCours) est nécessaire. Il faut donc :
1) Supprimer tous les codes événementiels des feuilles mois.
2) Copiez le code suivant dans un module standard
VB:
Const FIRST_CELL_DATA As String = "F3"  'La première cellule des data

Sub BilanInterCours()
Dim S As Worksheet
Dim S1 As Worksheet 'Feuille réceptrice
Dim V As Validation
Dim R As Range
Dim Formateurs As Variant
Dim Cours As Variant
Dim var As Variant
Dim var2 As Variant
Dim T()   'Tableau dynamique intervenants
Dim T2()  'Tableau dynamique heures
Dim LastLig&
Dim i&
Dim j&
Dim g&
Dim h&
Dim A$
Dim NbCol&
Dim C As Range
'--- Les titres ---
Set S = Sheets("Menus")
Formateurs = S.Range("A2:A" & S.[a2].End(xlDown).Row & "")
Cours = S.Range("B2:B" & S.[b2].End(xlDown).Row & "")
'--- Nouvelle feuille réceptrice BILANSx (n'écrase pas les feuilles BILANS existantes) ---
Set S1 = Worksheets.Add(After:=Sheets(Sheets.Count)) '("BILANSx")
On Error Resume Next
Do
  Err.Clear
  i& = i& + 1
  S1.Name = "BILANS" & i&
Loop Until Err = 0
On Error GoTo 0
'--- Ne traite que les sheets contenant une validation en F3 ---
For Each S In ThisWorkbook.Worksheets
  Set V = S.Range(FIRST_CELL_DATA).Validation
  On Error Resume Next
  Err.Clear
  A$ = V.Formula1
  If Err = 0 Then
    '--- Les Tableaux ---
          '°°° Tableau des intervenants °°°
    Erase T
    ReDim T(1 To UBound(Formateurs) + 1, 1 To UBound(Cours) + 2)
    For i& = 2 To UBound(T, 1)
      T(i&, 1) = Formateurs(i& - 1, 1)
    Next i&
    For j& = 3 To UBound(T, 2)
      T(1, j&) = Cours(j& - 2, 1)
    Next j&
          '°°° Tableau des heures °°°
    Erase T2
    ReDim T2(1 To UBound(Formateurs) + 1, 1 To UBound(Cours) + 2)
    For i& = 2 To UBound(T2, 1)
      T2(i&, 1) = Formateurs(i& - 1, 1)
    Next i&
    For j& = 3 To UBound(T2, 2)
      T2(1, j&) = Cours(j& - 2, 1)
    Next j&
    '--- Les données ---
    Set R = S.Range(FIRST_CELL_DATA)
    If R <> "" Then
      '--- Algorithme somme des intervenants ---
      LastLig& = S.[f65536].End(xlUp).Row
      Set R = R.Resize(LastLig& - R.Row + 1, R.Columns.Count + 5)
      var = R
      For i& = 1 To UBound(var, 1)
        For h& = 1 To UBound(Cours, 1)
          If var(i&, 1) = Cours(h&, 1) Then
            For j& = 1 To UBound(var, 2)
              For g& = 1 To UBound(Formateurs, 1)
                If var(i&, j&) = Formateurs(g&, 1) Then
                  T(g& + 1, h& + 2) = T(g& + 1, h& + 2) + 1
                  T(g& + 1, 2) = T(g& + 1, 2) + 1
                End If
              Next g&
            Next j&
          End If
        Next h&
      Next i&
      T(1, 1) = S.Name
      T(1, 2) = "TOTAL cours"
      '--- Algorithme somme des heures ---
      Set R = R.Offset(0, -3)
      Set R = R.Resize(R.Rows.Count, 2)
      var2 = R
      For i& = 1 To UBound(var, 1)
        For h& = 1 To UBound(Cours, 1)
          If var(i&, 1) = Cours(h&, 1) Then
            For j& = 1 To UBound(var, 2)
              For g& = 1 To UBound(Formateurs, 1)
                If var(i&, j&) = Formateurs(g&, 1) Then
                  T2(g& + 1, h& + 2) = var2(i&, 2) - var2(i&, 1)
                End If
              Next g&
            Next j&
          End If
        Next h&
      Next i&
      T2(1, 1) = S.Name
      T2(1, 2) = "TOTAL heures"
      '--- Inscription ---
      If S1.UsedRange.Rows.Count = 1 Then
        Set R = S1.Range("A1")
      Else
        Set R = S1.Range("A" & S1.UsedRange.Rows.Count + 2)
      End If
          '°°° Intervenants °°°
      Set R = R.Resize(UBound(T, 1), UBound(T, 2))
      R = T
          '°°° Heures °°°
      Set R = R.Offset(0, R.Columns.Count)
      R = T2
      R.NumberFormat = "hh:mm"
          '°°° Total des heures °°°
      NbCol& = R.Columns.Count - 2
      Set R = R.Resize(R.Rows.Count - 1, 1)
      Set R = R.Offset(1, 1)
      R.FormulaR1C1 = "=SUM(RC[1]:RC[" & NbCol& & "])"
      R.NumberFormat = "d""j /"" hh:mm"  'Format nécessaire pour somme supérieure à 24:00
      var2 = R
      R = var2
      '--- Efface les sommes = 0 ---
      For Each C In R
        If C = 0 Then C.ClearContents
      Next C
    End If
  End If
Next S
End Sub


3) Corrigez le code de la Sub Tri() par le code suivant
VB:
Sub Tri()
Dim LastRow As Long
'/// modif pmo il faut distinguer les tris des 2 colonnes ///
LastRow = Sheets("Menus").Range("A2").End(xlDown).Row
Range("A2:A" & LastRow).Sort Key1:=Range("A2"), Order1:=xlAscending, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase _
  :=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
  DataOption2:=xlSortNormal
 
LastRow = Sheets("Menus").Range("B2").End(xlDown).Row
Range("B2:B" & LastRow).Sort Key1:=Range("B2"), Order1:=xlAscending, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase _
  :=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
  DataOption2:=xlSortNormal
End Sub

Chaque fois que vous lancerez la procédure, une feuille BILANSx sera créée afin de ne pas écraser les existantes sur lesquelles vous auriez pu mettre des annotations ou commentaires.
 

Pièces jointes

  • methodotest_pmo 2.00.xlsm
    102.9 KB · Affichages: 55

Bulr6

XLDnaute Nouveau
Bonjour PMO,
Encore merci pour le temps investit et le travail réalisé !
Je vais juste essayé de modifier le code pour justement écraser les données sur la même feuille (aussi conserver le lancement de la procédure à chaque changement sur chaque feuille) et pour traiter toutes feuilles. Comme les feuille mois sont aussi utilisé comme une sorte de planing il est possible qu'il n'y ait pas de cours le premier jour du mois donc pas seulement celles qui ont des données en F3.

Si je peine à le modifier je me permettrais de demander un coup de main.
 

Bulr6

XLDnaute Nouveau
Bonjour PMO,
Je me permets à nouveau de te solliciter. J'ai réussi dans un test à modifier le fichier pour qu'il puisse écraser les données sur la Feuille BILANS sans en ouvrir un autre. J'ai encore du mal à ne pas limiter la création des tableaux au seul Feuille qui contiennent une données en F3 ... mais ce n'est pas le plus important.
Par contre j'ai un gros soucis avec le calcul des heures réalisés par cours. Explicitement, la somme ne se réalise pas correctement par cours : exemple dans le fichier Yann qui en septembre à réalisé 3 TD1 pour une durée totale de 5h (2+2+1) dans le bilan il ne prend en compte que le dernier TD1 celui de 1h dans la colonne bilan / heure / TD1 ? Je suis reparti de ton fichier d'origine donc je ne comprend pas l'erreur.
 

Pièces jointes

  • methodotest_pmo 2.00.xlsm
    96.9 KB · Affichages: 47

PMO2

XLDnaute Accro
Bonjour,
Une nouvelle version où
1) toutes les feuilles comportant une Validation sont traitées même si certaines sont vides
2) chaque changement sur les feuilles met à jour la feuille BILANS par le biais de la procédure événementielle Workbook_SheetChange dans la fenêtre de code de ThisWorkbook

Voir les codes
ThisWorkbook Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Module2 Sub BilanInterCours()
 

Pièces jointes

  • methodotest_pmo 2.01.xlsm
    98.9 KB · Affichages: 55

Bulr6

XLDnaute Nouveau
Parfait encore une fois ... Du cou, j'essaie de travailler ton code pour le comprendre je prends en exemple mon fichier et j'essaie d'appliquer la même méthode pour ajouter un 3e tableau pour le nombre de participants (en plus du nombre de cours et du calcul d'heures consacrées) ...pour l'instant j'arrive à créer et inscrire le tableau c'est la méthode pour additionner les valeurs qui me pose problème

VB:
If var(i&, j&) = Formateurs(g&, 1) Then
                  T3(g& + 1, h& + 2) = T3(g& + 1, h& + 2) + var3(i&, 1)
End If

EN plus j'imagine bien que c'est à cet endroit que ça bloque
 

Pièces jointes

  • methodotest_pmo 2.01.xlsm
    110.5 KB · Affichages: 45

PMO2

XLDnaute Accro
Bonjour,
Il n'y a pas que cette instruction qui crée le dysfonctionnement.
Voici un nouveau code (voir les '///)
VB:
Const FIRST_CELL_DATA As String = "F3"  'La première cellule des data

Sub BilanInterCours()
Dim S As Worksheet
Dim S1 As Worksheet 'Feuille réceptrice
Dim V As Validation
Dim R As Range
Dim R2 As Range '///ajout pmo
Dim Formateurs As Variant
Dim Cours As Variant
Dim var As Variant
Dim var2 As Variant
Dim var3 As Variant
Dim T()   'Tableau dynamique intervenants
Dim T2()  'Tableau dynamique heures
Dim T3()  'Tableau dynamique Participants
Dim LastLig&
Dim i&
Dim j&
Dim g&
Dim h&
Dim A$
Dim NbCol&
Dim C As Range
'--- Les titres ---
Set S = Sheets("Menus")
Formateurs = S.Range("A2:A" & S.[a2].End(xlDown).Row & "")
Cours = S.Range("B2:B" & S.[b2].End(xlDown).Row & "")
'--- Feuille réceptrice BILANS ---
On Error Resume Next
Set S1 = Sheets("BILANS")
If S1 Is Nothing Then
  Set S1 = Sheets.Add(after:=Sheets(Sheets.Count))
  S1.Name = "BILANS"
Else
  S1.Cells.Clear
End If
On Error GoTo 0
'--- Ne traite que les sheets contenant une validation en F3 ---
For Each S In ThisWorkbook.Worksheets
  Set V = S.Range(FIRST_CELL_DATA).Validation
  On Error Resume Next
  Err.Clear
  A$ = V.Formula1
  If Err = 0 Then
    '--- Les Tableaux ---
          '°°° Tableau des intervenants °°°
    Erase T
    ReDim T(1 To UBound(Formateurs) + 1, 1 To UBound(Cours) + 2)
    For i& = 2 To UBound(T, 1)
      T(i&, 1) = Formateurs(i& - 1, 1)
    Next i&
    For j& = 3 To UBound(T, 2)
      T(1, j&) = Cours(j& - 2, 1)
    Next j&
          '°°° Tableau des heures °°°
    Erase T2
    ReDim T2(1 To UBound(Formateurs) + 1, 1 To UBound(Cours) + 2)
    For i& = 2 To UBound(T2, 1)
      T2(i&, 1) = Formateurs(i& - 1, 1)
    Next i&
    For j& = 3 To UBound(T2, 2)
      T2(1, j&) = Cours(j& - 2, 1)
    Next j&
          '°°° Tableau des participants
    Erase T3
    ReDim T3(1 To UBound(Formateurs) + 1, 1 To UBound(Cours) + 2)
    For i& = 2 To UBound(T3, 1)
      T3(i&, 1) = Formateurs(i& - 1, 1)
    Next i&
    For j& = 3 To UBound(T3, 2)
      T3(1, j&) = Cours(j& - 2, 1)
    Next j&
    '--- Les données ---
    Set R = S.Range(FIRST_CELL_DATA)
    '--- Algorithme somme des intervenants ---
    LastLig& = S.[f65536].End(xlUp).Row
    Set R = R.Resize(LastLig& - R.Row + 1, R.Columns.Count + 5)
    var = R
    For i& = 1 To UBound(var, 1)
      For h& = 1 To UBound(Cours, 1)
        If var(i&, 1) = Cours(h&, 1) Then
          For j& = 1 To UBound(var, 2)
            For g& = 1 To UBound(Formateurs, 1)
              If var(i&, j&) = Formateurs(g&, 1) Then
                If S.Range(FIRST_CELL_DATA) <> "" Then
                  T(g& + 1, h& + 2) = T(g& + 1, h& + 2) + 1
                  T(g& + 1, 2) = T(g& + 1, 2) + 1
                End If
              End If
            Next g&
          Next j&
        End If
      Next h&
    Next i&
    T(1, 1) = S.Name
    T(1, 2) = "TOTAL cours"
    '--- Algorithme somme des heures ---
    Set R = R.Offset(0, -3)
    Set R = R.Resize(R.Rows.Count, 2)
    var2 = R
    For i& = 1 To UBound(var, 1)
      For h& = 1 To UBound(Cours, 1)
        If var(i&, 1) = Cours(h&, 1) Then
          For j& = 1 To UBound(var, 2)
            For g& = 1 To UBound(Formateurs, 1)
              If var(i&, j&) = Formateurs(g&, 1) Then
                T2(g& + 1, h& + 2) = T2(g& + 1, h& + 2) + var2(i&, 2) - var2(i&, 1)
              End If
            Next g&
          Next j&
        End If
      Next h&
    Next i&
    T2(1, 1) = S.Name
    T2(1, 2) = "TOTAL heures"
    '--- Algorithme somme des Participants ---
    Set R = R.Offset(0, 11)           '///modif pmo
    Set R = R.Resize(R.Rows.Count, 1) '///modif pmo
    var3 = R
    For i& = 1 To UBound(var, 1)
      For h& = 1 To UBound(Cours, 1)
        If var(i&, 1) = Cours(h&, 1) Then
          For j& = 1 To UBound(var, 2)
            For g& = 1 To UBound(Formateurs, 1)
              If var(i&, j&) = Formateurs(g&, 1) Then
                  T3(g& + 1, h& + 2) = T3(g& + 1, h& + 2) + var3(i&, 1)
                  T3(g& + 1, 2) = T3(g& + 1, 2) + var3(i&, 1)  '///modif pmo
              End If
            Next g&
          Next j&
        End If
      Next h&
    Next i&
    T3(1, 1) = S.Name
    T3(1, 2) = "TOTAL Participants"
    '--- Inscription ---
    On Error GoTo Erreur
    Application.EnableEvents = False '///ajout pmo
    If S1.UsedRange.Rows.Count = 1 Then
      Set R = S1.Range("A1")
    Else
      Set R = S1.Range("A" & S1.UsedRange.Rows.Count + 2)
    End If
        '°°° Intervenants °°°
    Set R = R.Resize(UBound(T, 1), UBound(T, 2))
    R.Borders.Weight = xlThin
    R.Columns(2).Interior.Color = vbYellow  '///ajout pmo
    R = T
        '°°° Heures °°°
    Set R = R.Offset(0, R.Columns.Count)
    R.Borders.Weight = xlThin
    R.Columns(2).Interior.Color = vbCyan  '///ajout pmo
    R = T2
    R.NumberFormat = "hh:mm"
        '°°° Total des heures °°°
    NbCol& = R.Columns.Count - 2
    '//////////////////////////////////////////////////////////////////////
    '/// on utilise une autre variable Range (R2) pour ne pas écraser R ///
    Set R2 = R
    Set R2 = R2.Resize(R2.Rows.Count - 1, 1)
    Set R2 = R2.Offset(1, 1)
    R2.FormulaR1C1 = "=SUM(RC[1]:RC[" & NbCol& & "])"
    R2.NumberFormat = "d""j /"" hh:mm"  'Format nécessaire pour somme supérieure à 24:00
    var2 = R2
    R2 = var2
    '--- Efface les sommes = 0 ---
    For Each C In R2
      If C = 0 Then C.ClearContents
    Next C
    '//////////////////////////////////////////////////////////////////////
        '°°° Participants °°°
    Set R = R.Offset(0, R.Columns.Count)
    R.Borders.Weight = xlThin
    R.Columns(2).Interior.Color = RGB(253, 233, 217) '///ajout pmo
    R = T3
  End If
Next S
Erreur:
'--- Pseudo traitement d'erreur ---
Application.EnableEvents = True '///ajout pmo
End Sub
 

Pièces jointes

  • methodotest_pmo 2.02.xlsm
    109.9 KB · Affichages: 77

Discussions similaires