Bonsoir
j'ai un code mais je n'arrive pas à récupérer les valeurs qui sont en décimale.
voici le code :
Private FlagInitForm As Boolean
Private SHR As Worksheet
Private TempsDemarrage As Long
Private NBColonneResultat As Long
Private TitreDATA As String
Private NbQuestion As Integer
' Enregistrement de la sélection puis Résultats
Private Sub BtnOk_Click()
Me.Hide
DoEvents
TempsDemarrage = Timer
LimitePercent = Val(cmbLimite.Text) / 100
LoadingNomenclature
'// Enregistrement de la sélection
Set SHR = ActiveWorkbook.Worksheets("Résultat Détaillé")
SHR.Cells(1, 1) = " "
For T = 0 To ListActivite.ListCount - 1
If ListActivite.Selected(T) Then
SEL_Activite = LCase(ListActivite.List(T))
End If
Next
For T = 0 To T = 7
If ListLieu.Selected(T) Then
SEL_Lieu = LCase(ListLieu.List(T))
End If
Next
For T = 0 To ListGare.ListCount - 1
If ListGare.Selected(T) Then
Gare = ListGare.List(T)
SEL_Gare = LCase(ListGare.List(T))
End If
Next
For T = 0 To ListTrain.ListCount - 1
If ListTrain.Selected(T) Then
SEL_Train = LCase(ListTrain.List(T))
End If
Next
For T = 0 To ListLigne.ListCount - 1
If ListLigne.Selected(T) Then
SEL_Ligne = LCase(ListLigne.List(T))
End If
Next
Set SH = ActiveWorkbook.Worksheets("DATA")
If TypeName(AllData) = "Empty" Then
NbLignes = SH.Cells(SH.Rows.Count, 1).End(xlUp).Row
NbColonnes = SH.Cells(1, 1).End(xlToRight).Column
ReDim AllData(1 To NbLignes, 1 To NbColonnes)
AllData = SH.Range(SH.Cells(1, 1), SH.Cells(NbLignes, NbColonnes))
End If
Set SHOld = ActiveWorkbook.Worksheets("DATAOld")
If TypeName(OldData) = "Empty" Then
NbLignes = SHOld.Cells(SH.Rows.Count, 1).End(xlUp).Row
NbColonnes = SHOld.Cells(1, 1).End(xlToRight).Column
ReDim OldData(1 To NbLignes, 1 To NbColonnes)
OldData = SHOld.Range(SHOld.Cells(1, 1), SHOld.Cells(NbLignes, NbColonnes))
End If
AnaylseDonnees
Delta = Timer - TempsDemarrage
SHR.Cells(1, 1) = "OK en " & Round(Delta, 1) & "s"
SHR.Cells(5, 1) = TitreDATA
Unload Me
End Sub
'////////////////////////////////////////////
' Analyse des données et Création Résultats
'////////////////////////////////////////////
Private Sub AnaylseDonnees()
NbData = 0
Total = 0
ColonActivite = 1
ColonGare = 2
ColonLieu = 3
ColonTrain = 4
ColonLigne = 6
NbQuestion = NBColonneResultat
XStart = 6
'// Calcul des résultats de cet année
ReDim RESULT(NbQuestion, 32)
NbT = 0
aCodeGroup = SEL_Gare
If Mid(SEL_Gare, 1, 1) = "[" Then
aCodeGroup = Mid(SEL_Gare, 2, Len(SEL_Gare) - 2)
End If
For l = 2 To UBound(AllData, 1)
Activite = AllData(l, ColonActivite)
Gare = AllData(l, ColonGare)
Lieu = AllData(l, ColonLieu)
Train = AllData(l, ColonTrain)
Ligne = AllData(l, ColonLigne)
IsSelect = True
If LCase(Activite) <> SEL_Activite And SEL_Activite <> "toutes" Then IsSelect = False
If Mid(SEL_Gare, 1, 1) = "[" Then
' Recherche Groupe de la gare
aGroup = FindGroupGare(Gare)
If LCase(aCodeGroup) <> LCase(aGroup) Then IsSelect = False
'Debug.Print Gare
Else
If LCase(Gare) <> SEL_Gare And SEL_Gare <> "toutes" Then
IsSelect = False
End If
End If
If LCase(Lieu) <> SEL_Lieu And SEL_Lieu <> "tous" Then IsSelect = False
If LCase(Train) <> SEL_Train And SEL_Train <> "tous" Then IsSelect = False
If LCase(Ligne) <> SEL_Ligne And SEL_Ligne <> "toutes" Then IsSelect = False
If IsSelect Then
NbT = NbT + 1
TypeJOUR = UCase(AllData(l, 5))
Select Case TypeJOUR
Case "Trimestre 1", "T1": DecJour = 1
Case "Trimestre 2", "T2": DecJour = 2
Case "Trimestre 3", "T3": DecJour = 3
Case "Trimestre 4", "T4": DecJour = 4
' Case "VENDREDI", "VEN": DecJour = 5
' Case "SAMEDI", "SAM": DecJour = 6
' Case "DIMANCHE", "DIM": DecJour = 7
End Select
'ToutesZones = AllData(l, 6)
'Total = Total + ToutesZones
For col = 1 To NbQuestion
T = "" & AllData(l, XStart + col)
C = "" & AllData(l, XStart + NbQuestion + col)
NC = "" & AllData(l, XStart + NbQuestion + NbQuestion + col)
If T <> "" Then
' TOTAL
RESULT(col, 1) = RESULT(col, 1) + Val(T)
RESULT(col, 2) = RESULT(col, 2) + Val(C)
RESULT(col, 3) = RESULT(col, 3) + Val(NC)
' LUN, MAR, MER, JEU, VEN, SAM, DIM
RESULT(col, 1 + DecJour * 3) = RESULT(col, 1 + DecJour * 3) + Val(T)
RESULT(col, 2 + DecJour * 3) = RESULT(col, 2 + DecJour * 3) + Val(C)
RESULT(col, 3 + DecJour * 3) = RESULT(col, 3 + DecJour * 3) + Val(NC)
End If
Next
Else
End If
Next
'// Calcul des résultats de l'année précédente
ReDim oldRESULT(NbQuestion, 32)
ObT = 0
For l = 2 To UBound(OldData, 1)
Activite = OldData(l, ColonActivite)
Gare = OldData(l, ColonGare)
Lieu = OldData(l, ColonLieu)
Train = OldData(l, ColonTrain)
Ligne = OldData(l, ColonLigne)
IsSelect = True
If LCase(Activite) <> SEL_Activite And SEL_Activite <> "toutes" Then IsSelect = False
If Mid(SEL_Gare, 1, 1) = "[" Then
' Recherche Groupe de la gare
aGroup = FindGroupGare(Gare)
If aCodeGroup <> aGroup Then IsSelect = False
'Debug.Print Gare
Else
If LCase(Gare) <> (SEL_Gare) And SEL_Gare <> "toutes" Then IsSelect = False
End If
If IsSelect Then
'Stop
End If
If LCase(Lieu) <> (SEL_Lieu) And SEL_Lieu <> "tous" Then IsSelect = False
If LCase(Train) <> (SEL_Train) And SEL_Train <> "tous" Then IsSelect = False
If LCase(Ligne) <> (SEL_Ligne) And SEL_Ligne <> "toutes" Then IsSelect = False
If IsSelect Then
ObT = ObT + 1
TypeJOUR = UCase(OldData(l, 5))
Select Case TypeJOUR
Case "Trimestre 1", "T1": DecJour = 1
Case "Trimestre 2", "T2": DecJour = 2
Case "Trimestre 3", "T3": DecJour = 3
Case "Trimestre 4", "T4": DecJour = 4
' Case "VENDREDI", "VEN": DecJour = 5
' Case "SAMEDI", "SAM": DecJour = 6
' Case "DIMANCHE", "DIM": DecJour = 7
End Select
'ToutesZones = AllData(l, 6)
'Total = Total + ToutesZones
For col = 1 To NbQuestion
T = "" & OldData(l, XStart + col)
C = "" & OldData(l, XStart + NbQuestion + col)
NC = "" & OldData(l, XStart + 2 * NbQuestion + col)
If T <> "" Then
' TOTAL
oldRESULT(col, 1) = oldRESULT(col, 1) + Val(T)
oldRESULT(col, 2) = oldRESULT(col, 2) + Val(C)
oldRESULT(col, 3) = oldRESULT(col, 3) + Val(NC)
' LUN, MAR, MER, JEU, VEN, SAM, DIM
oldRESULT(col, 1 + DecJour * 3) = oldRESULT(col, 1 + DecJour * 3) + Val(T)
oldRESULT(col, 2 + DecJour * 3) = oldRESULT(col, 2 + DecJour * 3) + Val(C)
oldRESULT(col, 3 + DecJour * 3) = oldRESULT(col, 3 + DecJour * 3) + Val(NC)
End If
Next
End If
Next
'// Affichage des résultats
Y = 9
SHR.Cells.ClearContents
SHR.Cells(1, 2) = "N : " & NbT
SHR.Cells(1, 7) = "N-1 : " & ObT
SHR.Cells(Y - 3, 1) = "Trimestre :"
SHR.Cells(Y - 3, 2) = UCase(SEL_Activite)
SHR.Cells(Y - 3, 7) = "Gare :"
SHR.Cells(Y - 3, 8) = UCase(SEL_Gare)
SHR.Cells(Y - 3, 13) = "Type Jour :"
SHR.Cells(Y - 3, 16) = UCase(SEL_Lieu)
SHR.Cells(Y - 3, 19) = "Mois :"
SHR.Cells(Y - 3, 23) = UCase(SEL_Train)
If LCase(Ligne) <> SEL_Ligne And SEL_Ligne <> "toutes" Then
SHR.Cells(Y - 2, 1) = "Date :"
SHR.Cells(Y - 2, 2) = UCase(SEL_Ligne)
End If
SHR.Cells(Y, 1) = "Zones observées"
For J = 0 To 4
Select Case J
Case 0: JourTxt = "TOTAL"
Case 1: JourTxt = "Trimestre 1"
Case 2: JourTxt = "Trimestre 2"
Case 3: JourTxt = "Trimestre 3"
Case 4: JourTxt = "Trimestre 4"
'Case 5: JourTxt = "VENDREDI"
'Case 6: JourTxt = "SAMEDI"
'Case 7: JourTxt = "DIMANCHE"
End Select
SHR.Cells(Y - 1, 2 + J * 6) = JourTxt
SHR.Cells(Y, 2 + J * 6) = "obs"
SHR.Cells(Y, 3 + J * 6) = "eff nc"
SHR.Cells(Y, 4 + J * 6) = "%nc"
SHR.Cells(Y, 5 + J * 6) = "eff c"
SHR.Cells(Y, 6 + J * 6) = "%c(n-1)"
SHR.Cells(Y, 7 + J * 6) = "Evol" & vbCrLf & "(+/- " & Round(LimitePercent * 100, 0) & "%)"
Next
Y = Y + 1
For col = 1 To NbQuestion
Nom = AllData(1, XStart + col)
Nom = Replace(Nom, "_T", "")
Titre = GetTitreQuestion(Nom)
If Titre = "" Then Titre = Nom
If Mid(Titre, 1, 1) = "[" Then
Titre = Mid(Titre, 2, Len(Titre) - 2)
If Y <> 10 Then
Y = Y + 1
End If
End If
If chkShowCode.Value <> 0 Then
If Nom = Titre Then
SHR.Cells(Y, 1) = Titre
Else
SHR.Cells(Y, 1) = Nom & " - " & Titre
End If
Else
SHR.Cells(Y, 1) = Titre
End If
For J = 0 To 7
SHR.Cells(Y, 2 + J * 6) = RESULT(col, 1 + J * 3) ' obs
SHR.Cells(Y, 3 + J * 6) = RESULT(col, 3 + J * 3) ' eff nc
p1 = -1
If RESULT(col, 1 + J * 3) <> 0 Then
p1 = RESULT(col, 3 + J * 3) / RESULT(col, 1 + J * 3) ' %nc
p3 = RESULT(col, 2 + J * 3) / RESULT(col, 1 + J * 3) ' %c
SHR.Cells(Y, 4 + J * 6) = p1
End If
p2 = -1
SHR.Cells(Y, 5 + J * 6) = RESULT(col, 2 + J * 3) ' eff c n-1
If oldRESULT(col, 1 + J * 3) <> 0 Then
p2 = oldRESULT(col, 2 + J * 3) / oldRESULT(col, 1 + J * 3) ' %c
p4 = oldRESULT(col, 3 + J * 3) / oldRESULT(col, 1 + J * 3) ' %nc
SHR.Cells(Y, 6 + J * 6) = p2 'oldRESULT(col, 3 + J * 3) & "/" & oldRESULT(col, 1 + J * 3)
End If
If p2 <> -1 And p1 <> -1 Then
Delta = (p3 - p2)
If Abs(Delta) > LimitePercent Then
If Delta > 0 Then
SHR.Cells(Y, 7 + J * 6) = "ì"
SHR.Cells(Y, 7 + J * 6).Font.Color = vbGreen
Else
SHR.Cells(Y, 7 + J * 6) = "î"
SHR.Cells(Y, 7 + J * 6).Font.Color = vbRed
End If
End If
End If
Next
Y = Y + 1
Next
SHR.Cells.EntireColumn.AutoFit
End Sub
Private Function FindGroupGare(ByVal Gare As String) As String
Set SH = ActiveWorkbook.Worksheets("Filtres")
NbLignes = SH.Cells(SH.Rows.Count, 2).End(xlUp).Row
NbColonnes = SH.Cells(1, 1).End(xlToRight).Column
For Y = 2 To NbLignes
aGare = SH.Cells(Y, 2)
aGroupe = SH.Cells(Y, 3)
If Gare = aGare Then
FindGroupGare = aGroupe
Exit For
End If
Next
End Function
Private Sub BtnOk_Enter()
End Sub
Private Sub chkShowCode_Click()
End Sub
Private Sub cmbLimite_Change()
End Sub
Private Sub Label1_Click()
End Sub
Private Sub lblActivite_Click()
End Sub
Private Sub lblLieu_Click()
End Sub
Private Sub lblLieu_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
End Sub
Private Sub lblLigne_Click()
End Sub
Private Sub lblTrain_Click()
End Sub
Private Sub ListActivite_Change()
ControlForm
End Sub
Private Sub ListGare_Change()
ControlForm
End Sub
Private Sub ListLieu_Change()
ControlForm
End Sub
Private Sub ListLigne_Click()
ControlForm
End Sub
Private Sub ListTrain_Change()
ControlForm
End Sub
'/////////////////////////////////////////////////////////
'// Control du Formulaire
'////////////////////////////////////////////////////////
Private Sub ControlForm()
FlagInitForm = False
NbActivite = 0
NbLieu = 0
NbGare = 0
NbTrain = 0
Set SHR = ActiveWorkbook.Worksheets("Résultat Détaillé")
SHR.Cells(1, 1) = " "
If ListActivite.ListCount <> 0 Then
For T = 0 To ListActivite.ListCount - 1
If ListActivite.Selected(T) Then
NbActivite = NbActivite + 1
End If
Next
End If
If NbActivite = 0 Then lblActivite.ForeColor = vbRed Else lblActivite.ForeColor = vbBlue
If ListLieu.ListCount <> 0 Then
For T = 0 To ListLieu.ListCount - 1
If ListLieu.Selected(T) Then
NbLieu = NbLieu + 1
End If
Next
End If
If NbLieu = 0 Then lblLieu.ForeColor = vbRed Else lblLieu.ForeColor = vbBlue
If ListGare.ListCount <> 0 Then
For T = 0 To ListGare.ListCount - 1
If ListGare.Selected(T) Then
NbGare = NbGare + 1
End If
Next
End If
If NbGare = 0 Then lblGare.ForeColor = vbRed Else lblGare.ForeColor = vbBlue
If ListTrain.ListCount <> 0 Then
For T = 0 To ListTrain.ListCount - 1
If ListTrain.Selected(T) Then
NbTrain = NbTrain + 1
End If
Next
End If
If NbTrain = 0 Then lblTrain.ForeColor = vbRed Else lblTrain.ForeColor = vbBlue
NbLigne = 0
If ListLigne.ListCount <> 0 Then
For T = 0 To ListLigne.ListCount - 1
If ListLigne.Selected(T) Then
NbLigne = NbLigne + 1
End If
Next
End If
If NbLigne = 0 Then lblLigne.ForeColor = vbRed Else lblLigne.ForeColor = vbBlue
If NbActivite <> 0 And NbLieu <> 0 And NbGare <> 0 And NbTrain <> 0 And NbLigne <> 0 Then
BtnOk.Enabled = True
Else
BtnOk.Enabled = False
End If
End Sub
'// Chargement de la nomenclature
'////////////////////////////////
Private Sub LoadingNomenclature()
Dim SH As Worksheet
Set SH = ActiveWorkbook.Worksheets("Nomenclature")
NbLignes = SH.Cells(SH.Rows.Count, 1).End(xlUp).Row
NbColonnes = SH.Cells(1, 1).End(xlToRight).Column
Set ColQuestion = New Collection
NBColonneResultat = SH.Cells(1, 3)
TitreDATA = SH.Cells(1, 1)
For Y = 2 To NbLignes
CodeQ = SH.Cells(Y, 1)
Titre = SH.Cells(Y, 2)
ColQuestion.Add Titre, "Q" & CodeQ
Next
End Sub
' Conversion Code Question -> Nomenclature
Private Function GetTitreQuestion(ByVal CodeQ As String) As String
On Error GoTo Echap
GetTitreQuestion = ""
GetTitreQuestion = ColQuestion("Q" & CodeQ)
Exit Function
Echap:
End Function
'// Chargement du formulaire
'////////////////////////////////
Private Sub UserForm_Initialize()
FlagInitForm = True
Set aSH = ActiveWorkbook.Worksheets("Filtres")
X = 1
NbLignes = aSH.Cells(aSH.Rows.Count, X).End(xlUp).Row
'Debug.Print ListActivite.RowSource
ListActivite.RowSource = "Filtres!A" & (X + 1) & ":A" & (NbLignes)
' Initialisation du Formulaire avec les données actuels
If SEL_Activite = "" Then SEL_Activite = ListActivite.List(0)
For T = 0 To ListActivite.ListCount - 1
If LCase(ListActivite.List(T)) = SEL_Activite Then
ListActivite.Selected(T) = True
Exit For
End If
Next
X = 4
NbLignes = aSH.Cells(aSH.Rows.Count, X).End(xlUp).Row
ListLieu.RowSource = "Filtres!D2
" & NbLignes
If SEL_Lieu = "" Then SEL_Lieu = ListLieu.List(0)
For T = 0 To ListLieu.ListCount - 1
If LCase(ListLieu.List(T)) = SEL_Lieu Then
ListLieu.Selected(T) = True
Exit For
End If
Next
X = 2
NbGare = aSH.Cells(aSH.Rows.Count, X).End(xlUp).Row
ListGare.RowSource = "Filtres!B2:B" & NbGare
If SEL_Gare = "" Then SEL_Gare = ListGare.List(0)
For T = 0 To ListGare.ListCount - 1
If LCase(ListGare.List(T)) = SEL_Gare Then
ListGare.Selected(T) = True
Exit For
End If
Next
X = 6
NbTrain = aSH.Cells(aSH.Rows.Count, X).End(xlUp).Row
ListTrain.RowSource = "Filtres!F2:F" & NbTrain
If SEL_Train = "" Then SEL_Train = ListTrain.List(0)
For T = 0 To ListTrain.ListCount - 1
If LCase(ListTrain.List(T)) = SEL_Train Then
ListTrain.Selected(T) = True
Exit For
End If
Next
X = 5
NbLigne = aSH.Cells(aSH.Rows.Count, X).End(xlUp).Row
ListLigne.RowSource = "Filtres!E2:E" & NbLigne
If SEL_Ligne = "" Then SEL_Ligne = ListLigne.List(0)
For T = 0 To ListLigne.ListCount - 1
If LCase(ListLigne.List(T)) = SEL_Ligne Then
ListLigne.Selected(T) = True
Exit For
End If
Next
LoadingNomenclature
Me.Caption = "Paramétrage du résultat " & TitreDATA
cmbLimite.Clear
cmbLimite.AddItem "10 %"
cmbLimite.AddItem "9 %"
cmbLimite.AddItem "8 %"
cmbLimite.AddItem "7 %"
cmbLimite.AddItem "6 %"
cmbLimite.AddItem "5 %"
cmbLimite.AddItem "4 %"
cmbLimite.AddItem "3 %"
cmbLimite.AddItem "2 %"
cmbLimite.AddItem "1 %"
cmbLimite.AddItem "0 %"
Find = False
For n = 0 To cmbLimite.ListCount - 1
V = Val(cmbLimite.List(n))
If V = (100 * LimitePercent) Then
cmbLimite.ListIndex = n
Find = True
Exit For
End If
Next
If Not Find Then cmbLimite.ListIndex = 5
FlagInitForm = False
ControlForm
End Sub
Voici un lien pour télécharger le fichier xls
merci pour votre aide
j'ai un code mais je n'arrive pas à récupérer les valeurs qui sont en décimale.
voici le code :
Private FlagInitForm As Boolean
Private SHR As Worksheet
Private TempsDemarrage As Long
Private NBColonneResultat As Long
Private TitreDATA As String
Private NbQuestion As Integer
' Enregistrement de la sélection puis Résultats
Private Sub BtnOk_Click()
Me.Hide
DoEvents
TempsDemarrage = Timer
LimitePercent = Val(cmbLimite.Text) / 100
LoadingNomenclature
'// Enregistrement de la sélection
Set SHR = ActiveWorkbook.Worksheets("Résultat Détaillé")
SHR.Cells(1, 1) = " "
For T = 0 To ListActivite.ListCount - 1
If ListActivite.Selected(T) Then
SEL_Activite = LCase(ListActivite.List(T))
End If
Next
For T = 0 To T = 7
If ListLieu.Selected(T) Then
SEL_Lieu = LCase(ListLieu.List(T))
End If
Next
For T = 0 To ListGare.ListCount - 1
If ListGare.Selected(T) Then
Gare = ListGare.List(T)
SEL_Gare = LCase(ListGare.List(T))
End If
Next
For T = 0 To ListTrain.ListCount - 1
If ListTrain.Selected(T) Then
SEL_Train = LCase(ListTrain.List(T))
End If
Next
For T = 0 To ListLigne.ListCount - 1
If ListLigne.Selected(T) Then
SEL_Ligne = LCase(ListLigne.List(T))
End If
Next
Set SH = ActiveWorkbook.Worksheets("DATA")
If TypeName(AllData) = "Empty" Then
NbLignes = SH.Cells(SH.Rows.Count, 1).End(xlUp).Row
NbColonnes = SH.Cells(1, 1).End(xlToRight).Column
ReDim AllData(1 To NbLignes, 1 To NbColonnes)
AllData = SH.Range(SH.Cells(1, 1), SH.Cells(NbLignes, NbColonnes))
End If
Set SHOld = ActiveWorkbook.Worksheets("DATAOld")
If TypeName(OldData) = "Empty" Then
NbLignes = SHOld.Cells(SH.Rows.Count, 1).End(xlUp).Row
NbColonnes = SHOld.Cells(1, 1).End(xlToRight).Column
ReDim OldData(1 To NbLignes, 1 To NbColonnes)
OldData = SHOld.Range(SHOld.Cells(1, 1), SHOld.Cells(NbLignes, NbColonnes))
End If
AnaylseDonnees
Delta = Timer - TempsDemarrage
SHR.Cells(1, 1) = "OK en " & Round(Delta, 1) & "s"
SHR.Cells(5, 1) = TitreDATA
Unload Me
End Sub
'////////////////////////////////////////////
' Analyse des données et Création Résultats
'////////////////////////////////////////////
Private Sub AnaylseDonnees()
NbData = 0
Total = 0
ColonActivite = 1
ColonGare = 2
ColonLieu = 3
ColonTrain = 4
ColonLigne = 6
NbQuestion = NBColonneResultat
XStart = 6
'// Calcul des résultats de cet année
ReDim RESULT(NbQuestion, 32)
NbT = 0
aCodeGroup = SEL_Gare
If Mid(SEL_Gare, 1, 1) = "[" Then
aCodeGroup = Mid(SEL_Gare, 2, Len(SEL_Gare) - 2)
End If
For l = 2 To UBound(AllData, 1)
Activite = AllData(l, ColonActivite)
Gare = AllData(l, ColonGare)
Lieu = AllData(l, ColonLieu)
Train = AllData(l, ColonTrain)
Ligne = AllData(l, ColonLigne)
IsSelect = True
If LCase(Activite) <> SEL_Activite And SEL_Activite <> "toutes" Then IsSelect = False
If Mid(SEL_Gare, 1, 1) = "[" Then
' Recherche Groupe de la gare
aGroup = FindGroupGare(Gare)
If LCase(aCodeGroup) <> LCase(aGroup) Then IsSelect = False
'Debug.Print Gare
Else
If LCase(Gare) <> SEL_Gare And SEL_Gare <> "toutes" Then
IsSelect = False
End If
End If
If LCase(Lieu) <> SEL_Lieu And SEL_Lieu <> "tous" Then IsSelect = False
If LCase(Train) <> SEL_Train And SEL_Train <> "tous" Then IsSelect = False
If LCase(Ligne) <> SEL_Ligne And SEL_Ligne <> "toutes" Then IsSelect = False
If IsSelect Then
NbT = NbT + 1
TypeJOUR = UCase(AllData(l, 5))
Select Case TypeJOUR
Case "Trimestre 1", "T1": DecJour = 1
Case "Trimestre 2", "T2": DecJour = 2
Case "Trimestre 3", "T3": DecJour = 3
Case "Trimestre 4", "T4": DecJour = 4
' Case "VENDREDI", "VEN": DecJour = 5
' Case "SAMEDI", "SAM": DecJour = 6
' Case "DIMANCHE", "DIM": DecJour = 7
End Select
'ToutesZones = AllData(l, 6)
'Total = Total + ToutesZones
For col = 1 To NbQuestion
T = "" & AllData(l, XStart + col)
C = "" & AllData(l, XStart + NbQuestion + col)
NC = "" & AllData(l, XStart + NbQuestion + NbQuestion + col)
If T <> "" Then
' TOTAL
RESULT(col, 1) = RESULT(col, 1) + Val(T)
RESULT(col, 2) = RESULT(col, 2) + Val(C)
RESULT(col, 3) = RESULT(col, 3) + Val(NC)
' LUN, MAR, MER, JEU, VEN, SAM, DIM
RESULT(col, 1 + DecJour * 3) = RESULT(col, 1 + DecJour * 3) + Val(T)
RESULT(col, 2 + DecJour * 3) = RESULT(col, 2 + DecJour * 3) + Val(C)
RESULT(col, 3 + DecJour * 3) = RESULT(col, 3 + DecJour * 3) + Val(NC)
End If
Next
Else
End If
Next
'// Calcul des résultats de l'année précédente
ReDim oldRESULT(NbQuestion, 32)
ObT = 0
For l = 2 To UBound(OldData, 1)
Activite = OldData(l, ColonActivite)
Gare = OldData(l, ColonGare)
Lieu = OldData(l, ColonLieu)
Train = OldData(l, ColonTrain)
Ligne = OldData(l, ColonLigne)
IsSelect = True
If LCase(Activite) <> SEL_Activite And SEL_Activite <> "toutes" Then IsSelect = False
If Mid(SEL_Gare, 1, 1) = "[" Then
' Recherche Groupe de la gare
aGroup = FindGroupGare(Gare)
If aCodeGroup <> aGroup Then IsSelect = False
'Debug.Print Gare
Else
If LCase(Gare) <> (SEL_Gare) And SEL_Gare <> "toutes" Then IsSelect = False
End If
If IsSelect Then
'Stop
End If
If LCase(Lieu) <> (SEL_Lieu) And SEL_Lieu <> "tous" Then IsSelect = False
If LCase(Train) <> (SEL_Train) And SEL_Train <> "tous" Then IsSelect = False
If LCase(Ligne) <> (SEL_Ligne) And SEL_Ligne <> "toutes" Then IsSelect = False
If IsSelect Then
ObT = ObT + 1
TypeJOUR = UCase(OldData(l, 5))
Select Case TypeJOUR
Case "Trimestre 1", "T1": DecJour = 1
Case "Trimestre 2", "T2": DecJour = 2
Case "Trimestre 3", "T3": DecJour = 3
Case "Trimestre 4", "T4": DecJour = 4
' Case "VENDREDI", "VEN": DecJour = 5
' Case "SAMEDI", "SAM": DecJour = 6
' Case "DIMANCHE", "DIM": DecJour = 7
End Select
'ToutesZones = AllData(l, 6)
'Total = Total + ToutesZones
For col = 1 To NbQuestion
T = "" & OldData(l, XStart + col)
C = "" & OldData(l, XStart + NbQuestion + col)
NC = "" & OldData(l, XStart + 2 * NbQuestion + col)
If T <> "" Then
' TOTAL
oldRESULT(col, 1) = oldRESULT(col, 1) + Val(T)
oldRESULT(col, 2) = oldRESULT(col, 2) + Val(C)
oldRESULT(col, 3) = oldRESULT(col, 3) + Val(NC)
' LUN, MAR, MER, JEU, VEN, SAM, DIM
oldRESULT(col, 1 + DecJour * 3) = oldRESULT(col, 1 + DecJour * 3) + Val(T)
oldRESULT(col, 2 + DecJour * 3) = oldRESULT(col, 2 + DecJour * 3) + Val(C)
oldRESULT(col, 3 + DecJour * 3) = oldRESULT(col, 3 + DecJour * 3) + Val(NC)
End If
Next
End If
Next
'// Affichage des résultats
Y = 9
SHR.Cells.ClearContents
SHR.Cells(1, 2) = "N : " & NbT
SHR.Cells(1, 7) = "N-1 : " & ObT
SHR.Cells(Y - 3, 1) = "Trimestre :"
SHR.Cells(Y - 3, 2) = UCase(SEL_Activite)
SHR.Cells(Y - 3, 7) = "Gare :"
SHR.Cells(Y - 3, 8) = UCase(SEL_Gare)
SHR.Cells(Y - 3, 13) = "Type Jour :"
SHR.Cells(Y - 3, 16) = UCase(SEL_Lieu)
SHR.Cells(Y - 3, 19) = "Mois :"
SHR.Cells(Y - 3, 23) = UCase(SEL_Train)
If LCase(Ligne) <> SEL_Ligne And SEL_Ligne <> "toutes" Then
SHR.Cells(Y - 2, 1) = "Date :"
SHR.Cells(Y - 2, 2) = UCase(SEL_Ligne)
End If
SHR.Cells(Y, 1) = "Zones observées"
For J = 0 To 4
Select Case J
Case 0: JourTxt = "TOTAL"
Case 1: JourTxt = "Trimestre 1"
Case 2: JourTxt = "Trimestre 2"
Case 3: JourTxt = "Trimestre 3"
Case 4: JourTxt = "Trimestre 4"
'Case 5: JourTxt = "VENDREDI"
'Case 6: JourTxt = "SAMEDI"
'Case 7: JourTxt = "DIMANCHE"
End Select
SHR.Cells(Y - 1, 2 + J * 6) = JourTxt
SHR.Cells(Y, 2 + J * 6) = "obs"
SHR.Cells(Y, 3 + J * 6) = "eff nc"
SHR.Cells(Y, 4 + J * 6) = "%nc"
SHR.Cells(Y, 5 + J * 6) = "eff c"
SHR.Cells(Y, 6 + J * 6) = "%c(n-1)"
SHR.Cells(Y, 7 + J * 6) = "Evol" & vbCrLf & "(+/- " & Round(LimitePercent * 100, 0) & "%)"
Next
Y = Y + 1
For col = 1 To NbQuestion
Nom = AllData(1, XStart + col)
Nom = Replace(Nom, "_T", "")
Titre = GetTitreQuestion(Nom)
If Titre = "" Then Titre = Nom
If Mid(Titre, 1, 1) = "[" Then
Titre = Mid(Titre, 2, Len(Titre) - 2)
If Y <> 10 Then
Y = Y + 1
End If
End If
If chkShowCode.Value <> 0 Then
If Nom = Titre Then
SHR.Cells(Y, 1) = Titre
Else
SHR.Cells(Y, 1) = Nom & " - " & Titre
End If
Else
SHR.Cells(Y, 1) = Titre
End If
For J = 0 To 7
SHR.Cells(Y, 2 + J * 6) = RESULT(col, 1 + J * 3) ' obs
SHR.Cells(Y, 3 + J * 6) = RESULT(col, 3 + J * 3) ' eff nc
p1 = -1
If RESULT(col, 1 + J * 3) <> 0 Then
p1 = RESULT(col, 3 + J * 3) / RESULT(col, 1 + J * 3) ' %nc
p3 = RESULT(col, 2 + J * 3) / RESULT(col, 1 + J * 3) ' %c
SHR.Cells(Y, 4 + J * 6) = p1
End If
p2 = -1
SHR.Cells(Y, 5 + J * 6) = RESULT(col, 2 + J * 3) ' eff c n-1
If oldRESULT(col, 1 + J * 3) <> 0 Then
p2 = oldRESULT(col, 2 + J * 3) / oldRESULT(col, 1 + J * 3) ' %c
p4 = oldRESULT(col, 3 + J * 3) / oldRESULT(col, 1 + J * 3) ' %nc
SHR.Cells(Y, 6 + J * 6) = p2 'oldRESULT(col, 3 + J * 3) & "/" & oldRESULT(col, 1 + J * 3)
End If
If p2 <> -1 And p1 <> -1 Then
Delta = (p3 - p2)
If Abs(Delta) > LimitePercent Then
If Delta > 0 Then
SHR.Cells(Y, 7 + J * 6) = "ì"
SHR.Cells(Y, 7 + J * 6).Font.Color = vbGreen
Else
SHR.Cells(Y, 7 + J * 6) = "î"
SHR.Cells(Y, 7 + J * 6).Font.Color = vbRed
End If
End If
End If
Next
Y = Y + 1
Next
SHR.Cells.EntireColumn.AutoFit
End Sub
Private Function FindGroupGare(ByVal Gare As String) As String
Set SH = ActiveWorkbook.Worksheets("Filtres")
NbLignes = SH.Cells(SH.Rows.Count, 2).End(xlUp).Row
NbColonnes = SH.Cells(1, 1).End(xlToRight).Column
For Y = 2 To NbLignes
aGare = SH.Cells(Y, 2)
aGroupe = SH.Cells(Y, 3)
If Gare = aGare Then
FindGroupGare = aGroupe
Exit For
End If
Next
End Function
Private Sub BtnOk_Enter()
End Sub
Private Sub chkShowCode_Click()
End Sub
Private Sub cmbLimite_Change()
End Sub
Private Sub Label1_Click()
End Sub
Private Sub lblActivite_Click()
End Sub
Private Sub lblLieu_Click()
End Sub
Private Sub lblLieu_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
End Sub
Private Sub lblLigne_Click()
End Sub
Private Sub lblTrain_Click()
End Sub
Private Sub ListActivite_Change()
ControlForm
End Sub
Private Sub ListGare_Change()
ControlForm
End Sub
Private Sub ListLieu_Change()
ControlForm
End Sub
Private Sub ListLigne_Click()
ControlForm
End Sub
Private Sub ListTrain_Change()
ControlForm
End Sub
'/////////////////////////////////////////////////////////
'// Control du Formulaire
'////////////////////////////////////////////////////////
Private Sub ControlForm()
FlagInitForm = False
NbActivite = 0
NbLieu = 0
NbGare = 0
NbTrain = 0
Set SHR = ActiveWorkbook.Worksheets("Résultat Détaillé")
SHR.Cells(1, 1) = " "
If ListActivite.ListCount <> 0 Then
For T = 0 To ListActivite.ListCount - 1
If ListActivite.Selected(T) Then
NbActivite = NbActivite + 1
End If
Next
End If
If NbActivite = 0 Then lblActivite.ForeColor = vbRed Else lblActivite.ForeColor = vbBlue
If ListLieu.ListCount <> 0 Then
For T = 0 To ListLieu.ListCount - 1
If ListLieu.Selected(T) Then
NbLieu = NbLieu + 1
End If
Next
End If
If NbLieu = 0 Then lblLieu.ForeColor = vbRed Else lblLieu.ForeColor = vbBlue
If ListGare.ListCount <> 0 Then
For T = 0 To ListGare.ListCount - 1
If ListGare.Selected(T) Then
NbGare = NbGare + 1
End If
Next
End If
If NbGare = 0 Then lblGare.ForeColor = vbRed Else lblGare.ForeColor = vbBlue
If ListTrain.ListCount <> 0 Then
For T = 0 To ListTrain.ListCount - 1
If ListTrain.Selected(T) Then
NbTrain = NbTrain + 1
End If
Next
End If
If NbTrain = 0 Then lblTrain.ForeColor = vbRed Else lblTrain.ForeColor = vbBlue
NbLigne = 0
If ListLigne.ListCount <> 0 Then
For T = 0 To ListLigne.ListCount - 1
If ListLigne.Selected(T) Then
NbLigne = NbLigne + 1
End If
Next
End If
If NbLigne = 0 Then lblLigne.ForeColor = vbRed Else lblLigne.ForeColor = vbBlue
If NbActivite <> 0 And NbLieu <> 0 And NbGare <> 0 And NbTrain <> 0 And NbLigne <> 0 Then
BtnOk.Enabled = True
Else
BtnOk.Enabled = False
End If
End Sub
'// Chargement de la nomenclature
'////////////////////////////////
Private Sub LoadingNomenclature()
Dim SH As Worksheet
Set SH = ActiveWorkbook.Worksheets("Nomenclature")
NbLignes = SH.Cells(SH.Rows.Count, 1).End(xlUp).Row
NbColonnes = SH.Cells(1, 1).End(xlToRight).Column
Set ColQuestion = New Collection
NBColonneResultat = SH.Cells(1, 3)
TitreDATA = SH.Cells(1, 1)
For Y = 2 To NbLignes
CodeQ = SH.Cells(Y, 1)
Titre = SH.Cells(Y, 2)
ColQuestion.Add Titre, "Q" & CodeQ
Next
End Sub
' Conversion Code Question -> Nomenclature
Private Function GetTitreQuestion(ByVal CodeQ As String) As String
On Error GoTo Echap
GetTitreQuestion = ""
GetTitreQuestion = ColQuestion("Q" & CodeQ)
Exit Function
Echap:
End Function
'// Chargement du formulaire
'////////////////////////////////
Private Sub UserForm_Initialize()
FlagInitForm = True
Set aSH = ActiveWorkbook.Worksheets("Filtres")
X = 1
NbLignes = aSH.Cells(aSH.Rows.Count, X).End(xlUp).Row
'Debug.Print ListActivite.RowSource
ListActivite.RowSource = "Filtres!A" & (X + 1) & ":A" & (NbLignes)
' Initialisation du Formulaire avec les données actuels
If SEL_Activite = "" Then SEL_Activite = ListActivite.List(0)
For T = 0 To ListActivite.ListCount - 1
If LCase(ListActivite.List(T)) = SEL_Activite Then
ListActivite.Selected(T) = True
Exit For
End If
Next
X = 4
NbLignes = aSH.Cells(aSH.Rows.Count, X).End(xlUp).Row
ListLieu.RowSource = "Filtres!D2
" & NbLignesIf SEL_Lieu = "" Then SEL_Lieu = ListLieu.List(0)
For T = 0 To ListLieu.ListCount - 1
If LCase(ListLieu.List(T)) = SEL_Lieu Then
ListLieu.Selected(T) = True
Exit For
End If
Next
X = 2
NbGare = aSH.Cells(aSH.Rows.Count, X).End(xlUp).Row
ListGare.RowSource = "Filtres!B2:B" & NbGare
If SEL_Gare = "" Then SEL_Gare = ListGare.List(0)
For T = 0 To ListGare.ListCount - 1
If LCase(ListGare.List(T)) = SEL_Gare Then
ListGare.Selected(T) = True
Exit For
End If
Next
X = 6
NbTrain = aSH.Cells(aSH.Rows.Count, X).End(xlUp).Row
ListTrain.RowSource = "Filtres!F2:F" & NbTrain
If SEL_Train = "" Then SEL_Train = ListTrain.List(0)
For T = 0 To ListTrain.ListCount - 1
If LCase(ListTrain.List(T)) = SEL_Train Then
ListTrain.Selected(T) = True
Exit For
End If
Next
X = 5
NbLigne = aSH.Cells(aSH.Rows.Count, X).End(xlUp).Row
ListLigne.RowSource = "Filtres!E2:E" & NbLigne
If SEL_Ligne = "" Then SEL_Ligne = ListLigne.List(0)
For T = 0 To ListLigne.ListCount - 1
If LCase(ListLigne.List(T)) = SEL_Ligne Then
ListLigne.Selected(T) = True
Exit For
End If
Next
LoadingNomenclature
Me.Caption = "Paramétrage du résultat " & TitreDATA
cmbLimite.Clear
cmbLimite.AddItem "10 %"
cmbLimite.AddItem "9 %"
cmbLimite.AddItem "8 %"
cmbLimite.AddItem "7 %"
cmbLimite.AddItem "6 %"
cmbLimite.AddItem "5 %"
cmbLimite.AddItem "4 %"
cmbLimite.AddItem "3 %"
cmbLimite.AddItem "2 %"
cmbLimite.AddItem "1 %"
cmbLimite.AddItem "0 %"
Find = False
For n = 0 To cmbLimite.ListCount - 1
V = Val(cmbLimite.List(n))
If V = (100 * LimitePercent) Then
cmbLimite.ListIndex = n
Find = True
Exit For
End If
Next
If Not Find Then cmbLimite.ListIndex = 5
FlagInitForm = False
ControlForm
End Sub
Voici un lien pour télécharger le fichier xls
merci pour votre aide
Dernière édition:
