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