Option Explicit
Public DateDebut, DateFin As Date
Public strNomFeuilleLabo, strNomFeuilleJeu, strNomFeuilleCusto As String
Public Arret As Integer
Sub IndicateursTests()
' Initialisations
Application.ScreenUpdating = False
Arret = 0
If Application.UserName = "toto" And Environ("username") = "tata" Then
' Sauvegarde du nom du fichier courant
strNomFichierCourant = ActiveWorkbook.Name
strNomFeuilleLabo = "Indicateurs labo"
strNomFeuilleJeu = "Indicateurs jeu"
strNomFeuilleCusto = "Indicateurs custo"
'Sélection des dates de l'analyse
Call SelectionDateRequete
If Arret = 0 Then
' Création d'un nouveau fichier
strNomFichier = Year(DateDebut) & Format(Month(DateDebut), "00") & Format(Day(DateDebut), "00") & "_" & Year(DateFin) & Format(Month(DateFin), "00") & Format(Day(DateFin), "00")
strNomFichier = strNomFichier & "_" & "Indicateurs Tests"
'ouverture d'un nouveau fichier raquette
Application.DisplayAlerts = False
Workbooks.Add
ActiveWorkbook.SaveAs "D:\...\2015\" & strNomFichier
strNomFichier = ActiveWorkbook.Name
Workbooks(strNomFichierCourant).Sheets(strNomFeuilleLabo).Copy After:=Workbooks(strNomFichier).Sheets(xlLast)
Workbooks(strNomFichierCourant).Sheets(strNomFeuilleJeu).Copy After:=Workbooks(strNomFichier).Sheets(strNomFeuilleLabo)
Workbooks(strNomFichierCourant).Sheets(strNomFeuilleCusto).Copy After:=Workbooks(strNomFichier).Sheets(strNomFeuilleJeu)
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Visible = True
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Visible = True
Workbooks(strNomFichier).Sheets(strNomFeuilleCusto).Visible = True
Workbooks(strNomFichier).Sheets("Feuil1").Delete
Workbooks(strNomFichier).Sheets("Feuil2").Delete
Workbooks(strNomFichier).Sheets("Feuil3").Delete
ActiveWorkbook.Save
Application.DisplayAlerts = True
Call ExporterListeCampagnesLabo
Call ExporterListeCampagnesJeu
Workbooks(strNomFichier).Save
Workbooks(strNomFichier).Close
Workbooks(strNomFichierCourant).Activate
MsgBox "Fichier créé", vbOKOnly, "Information"
End If
Else
MsgBox "Vous ne disposez pas des droits pour accéder à cet élément.", vbOKOnly, "Information"
End If
Application.ScreenUpdating = True
End Sub
Sub ExporterListeCampagnesLabo()
'chargement de la liste des campagnes laboratoire
Dim rst As ADODB.Recordset
Dim strSql, strSql1, strSql2 As String
Dim k, i As Integer
Application.ScreenUpdating = False
' Ouverture d'une connexion le cas échéant puis requêtage
Call ConnecterBaseOracle
k = 3
'--------------------------------------------------------
' liste de toutes les campagnes de tests au laboratoire
'--------------------------------------------------------
strSql = ""
strSql = "select distinct cmp.P_IDCAMPLABO,cmp.NOM, COALESCE(cmpballe.CDSPORT, cmpraq.CDSPORT, cmpcord.CDSPORT) AS CDSPORT, "
strSql = strSql & " case WHEN cmpballe.P_IDCAMPLABO IS NOT NULL THEN 'BALLE'"
strSql = strSql & " WHEN cmpraq.P_IDCAMPLABO IS NOT NULL THEN 'RAQUETTE'"
strSql = strSql & " WHEN cmpcord.P_IDCAMPLABO IS NOT NULL THEN 'CORDAGE'"
strSql = strSql & " end as Produit,cmpprojet.LIBELLE,'Labo' as Test,cmp.ETAT, trunc(cmp.DTDEMANDE), trunc(cmp.DTSOUHAIT), trunc(cmp.DTCLOTURE)"
strSql = strSql & " from CAMPLABO cmp"
strSql = strSql & " left join CAMPLABOBALLE cmpballe on cmpballe.P_IDCAMPLABO=cmp.P_IDCAMPLABO"
strSql = strSql & " left join CAMPLABORAQ cmpraq on cmpraq.P_IDCAMPLABO=cmp.P_IDCAMPLABO"
strSql = strSql & " left join CAMPLABOCORDAGE cmpcord on cmpcord.P_IDCAMPLABO=cmp.P_IDCAMPLABO"
strSql = strSql & " left join PROJET cmpprojet on cmpprojet.P_IDPROJET=cmp.F_IDPROJET"
If Len(DateDebut) = 0 And Len(DateFin) = 0 Then
strSql = strSql & " where "
ElseIf Len(DateDebut) > 0 And Len(DateFin) = 0 Then
strSql = strSql & " where trunc(cmp.DTCLOTURE)>='" & DateDebut & "' and"
ElseIf Len(DateDebut) > 0 And Len(DateFin) > 0 Then
strSql = strSql & " where trunc(cmp.DTCLOTURE)>='" & DateDebut & "' and trunc(cmp.DTCLOTURE)<='" & DateFin & "' and"
ElseIf Len(DateDebut) = 0 And Len(DateFin) > 0 Then
strSql = strSql & " where trunc(cmp.DTCLOTURE)<='" & DateFin & "' and"
End If
strSql = strSql & " cmp.ETAT<>'ABANDONNEE'"
strSql = strSql & " order by cmp.P_IDCAMPLABO desc"
'ouverture recorset
Set rst = New ADODB.Recordset
rst.Open strSql, cnx
If rst.EOF Then
Set rst = Nothing
Else
'remplissage du tableau excel
While Not rst.EOF
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 2) = rst.Fields(0).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 3) = rst.Fields(1).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 4) = rst.Fields(2).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 5) = rst.Fields(3).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 6) = rst.Fields(4).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 7) = rst.Fields(5).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 10) = rst.Fields(6).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 11) = rst.Fields(7).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 12) = rst.Fields(8).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 13) = rst.Fields(9).Value
rst.MoveNext
k = k + 1
Wend
End If
'------------------------------------------------
' liste de toutes les campagnes de pose cordage
'------------------------------------------------
strSql = ""
strSql = "select dde.P_IDDEANALYSE, cont.CDSPORT, 'CORDAGE' as Produit, 'Pose' as Test, '1' as NBProduit, '1' as Nbtest, dde.DTDEMANASTAT, dde.DATESOUHAIT, cont.DATEREAL "
strSql = strSql & " from DEMANDEANALYSE dde"
strSql = strSql & " inner join CONTROLE cont on cont.F_IDDEANALYSE=dde.P_IDDEANALYSE"
strSql = strSql & " where (dde.TESTCORDAGE='NORMAL' or dde.TESTCORDAGE='SEVERE')"
If Len(DateDebut) = 0 And Len(DateFin) = 0 Then
ElseIf Len(DateDebut) > 0 And Len(DateFin) = 0 Then
strSql = strSql & " and trunc(cont.DATEREAL)>='" & DateDebut & "'"
ElseIf Len(DateDebut) > 0 And Len(DateFin) > 0 Then
strSql = strSql & " and trunc(cont.DATEREAL)>='" & DateDebut & "' and trunc(cont.DATEREAL)<='" & DateFin & "'"
ElseIf Len(DateDebut) = 0 And Len(DateFin) > 0 Then
strSql = strSql & " and trunc(cont.DATEREAL)<='" & DateFin & "'"
End If
strSql = strSql & " order by dde.P_IDDEANALYSE desc"
'ouverture recorset
Set rst = New ADODB.Recordset
rst.Open strSql, cnx
If rst.EOF Then
Set rst = Nothing
Else
'remplissage du tableau excel
While Not rst.EOF
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 2) = rst.Fields(0).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 4) = rst.Fields(1).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 5) = rst.Fields(2).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 7) = rst.Fields(3).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 8) = rst.Fields(4).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 9) = rst.Fields(5).Value
If rst.Fields(8).Value <> "" Then Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 10) = "CLOTUREE"
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 11) = rst.Fields(6).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 12) = rst.Fields(7).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(k, 13) = rst.Fields(8).Value
rst.MoveNext
k = k + 1
Wend
End If
'--------------------------------------------------------
' Détermination du nb de produits et tests par campagne
'--------------------------------------------------------
For i = 3 To Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Range("B1048576").End(xlUp).Row
If Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(i, 7) = "Labo" Then
strSql1 = ""
strSql2 = ""
Select Case Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(i, 5)
Case "RAQUETTE"
strSql1 = "select count(P_IDRAQUETTE) from ETUDIE where P_IDCAMPLABO='" & Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(i, 2) & "'"
strSql2 = "select count(P_IDTESTLABORAQ) from TESTLABORAQ where F_IDCAMPLABORAQ='" & Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(i, 2) & "'"
Case "CORDAGE"
strSql1 = "select count(P_IDCORDPHYSIQ) from TESTE where P_IDCAMPLABO='" & Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(i, 2) & "'"
strSql2 = "select count(P_IDTESTLABO) from TESTLABO where F_IDCAMPLABO='" & Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(i, 2) & "'"
Case "BALLE"
strSql1 = "select count(P_IDBALLE) from TESTEBALLE where P_IDCAMPLABO='" & Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(i, 2) & "'"
strSql2 = "select count(COCHE) from TESTLABOBAL where P_IDCAMPLABO='" & Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(i, 2) & "'"
End Select
'ouverture recorset
Set rst = New ADODB.Recordset
rst.Open strSql1, cnx
If rst.EOF Then
Set rst = Nothing
Else
'remplissage du tableau excel
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(i, 8) = rst.Fields(0).Value
End If
Set rst = Nothing
Set rst = New ADODB.Recordset
rst.Open strSql2, cnx
If rst.EOF Then
Set rst = Nothing
Else
'remplissage du tableau excel
Workbooks(strNomFichier).Sheets(strNomFeuilleLabo).Cells(i, 9) = rst.Fields(0).Value
End If
End If
Next i
Application.ScreenUpdating = True
End Sub
Sub ExporterListeCampagnesJeu()
'chargement de la liste des campagnes jeu
Dim rst As ADODB.Recordset
Dim strSql As String
Dim k, i As Integer
Application.ScreenUpdating = False
' Ouverture d'une connexion le cas échéant puis requêtage
Call ConnecterBaseOracle
k = 3
'-----------------------------------------------------------------------------------
' liste de toutes les campagnes de tests au jeu Produit et Sensoriel non abandonnée
'-----------------------------------------------------------------------------------
strSql = ""
strSql = "select campsensa.P_IDCAMPSENSA, campsensa.NOM, campsensa.CDSPORT, campsensa.CDPRODUIT, proj.LIBELLE, "
strSql = strSql & " case WHEN campsensa.TYPE='S' THEN 'EXPERT'"
strSql = strSql & " WHEN campsensa.TYPE='P' THEN 'PRODUIT'"
strSql = strSql & " WHEN campsensa.TYPE='D' THEN 'DIFFERENCE/SIMILITUDE'"
strSql = strSql & " end as Test, campsensa.ETAT, campsensa.DTDEMANDE, campsensa.DTSOUHAIT, campsensa.DTEST+8 from CAMPSENSA campsensa"
strSql = strSql & " left join PROJET proj on proj.P_IDPROJET=campsensa.F_IDPROJET"
If Len(DateDebut) = 0 And Len(DateFin) = 0 Then
strSql = strSql & " where "
ElseIf Len(DateDebut) > 0 And Len(DateFin) = 0 Then
strSql = strSql & " where trunc(campsensa.DTCLOTURE)>='" & DateDebut & "' and"
ElseIf Len(DateDebut) > 0 And Len(DateFin) > 0 Then
strSql = strSql & " where trunc(campsensa.DTCLOTURE)>='" & DateDebut & "' and trunc(campsensa.DTCLOTURE)<='" & DateFin & "' and"
ElseIf Len(DateDebut) = 0 And Len(DateFin) > 0 Then
strSql = strSql & " where trunc(campsensa.DTCLOTURE)<='" & DateFin & "' and"
End If
strSql = strSql & " campsensa.ETAT<>'ABANDONNEE'"
strSql = strSql & " order by campsensa.P_IDCAMPSENSA desc"
'ouverture recorset
Set rst = New ADODB.Recordset
rst.Open strSql, cnx
If rst.EOF Then
Set rst = Nothing
Else
'remplissage du tableau excel
While Not rst.EOF
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 2) = rst.Fields(0).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 3) = rst.Fields(1).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 4) = rst.Fields(2).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 5) = rst.Fields(3).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 6) = rst.Fields(4).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 7) = rst.Fields(5).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 10) = rst.Fields(6).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 11) = rst.Fields(7).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 12) = rst.Fields(8).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 13) = rst.Fields(9).Value
rst.MoveNext
k = k + 1
Wend
End If
Application.ScreenUpdating = True
'----------------------------------------------------------------------------------------------------------------------------
' nombre de produits différents testés dans les campagnes de tests au jeu Produit et Sensoriel non abandonnées
'----------------------------------------------------------------------------------------------------------------------------
For i = 3 To Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Range("B1048576").End(xlUp).Row
If Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 7) = "EXPERT" Or Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 7) = "PRODUIT" Or Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 7) = "DIFFERENCE/SIMILITUDE" Then
strSql = ""
Select Case Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 5)
Case "RAQUETTE"
strSql = "select count(distinct(raq.LAYUP)) from ASSOCIE ass inner join RAQUETTE raq on raq.P_IDRAQUETTE=ass.P_IDRAQUETTE where P_IDCAMPSENSA='" & Cells(i, 2) & "'"
Case "CORDAGE"
strSql = "select count(P_IDCORDPHYSIQ) from ESTIME where P_IDCAMPSENSA='" & Cells(i, 2) & "'"
Case "BALLE"
strSql = "select count(distinct(balle.CODEECHANTILLON)) from TESTESENSA tsensa inner join BALLE balle on balle.P_IDBALLE=tsensa.P_IDBALLE where P_IDCAMPSENSA='" & Cells(i, 2) & "'"
Case "CHAUSSURE"
strSql = "select count(distinct(pch.F_ID_CHAUSSURE)) from PAIRECHAUSSURE pch "
strSql = strSql & "inner join PAIRECHAUSSURE_CAMPSENS pchsensa on pchsensa.PAIRE_ID=pch.P_IDPAIRECHAUSSURE "
strSql = strSql & "inner join CAMPSENSA cpsensa on cpsensa.P_IDCAMPSENSA=pchsensa.CAMPAGNE_ID "
strSql = strSql & "where cpsensa.P_IDCAMPSENSA='" & Cells(i, 2) & "'"
End Select
'ouverture recorset
If strSql <> "" Then
Set rst = New ADODB.Recordset
rst.Open strSql, cnx
If rst.EOF Then
Set rst = Nothing
Else
'remplissage du tableau excel
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 8) = rst.Fields(0).Value
End If
End If
End If
Next i
[COLOR="#FF0000"]'-----------------------------------------------------------------------------------------------------------------------------
' nombre de produits utilisés dans les campagnes de tests au jeu Produit, Sensoriel et différence/similitude non abandonnées
' - Campagnes raquettes : nombre de raquettes cordées = nombre de raquettes enregistrées dans la campagne
' - Campagnes cordages : nombre de raquettes cordées = nombre de cordages enregistrés dans la campagne *4
' - Campagnes chaussures : nombre de paires utilisées
'-----------------------------------------------------------------------------------------------------------------------------
For i = 3 To Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Range("B1048576").End(xlUp).Row
If Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 7) = "EXPERT" Or Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 7) = "PRODUIT" Or Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 7) = "DIFFERENCE/SIMILITUDE" Then
strSql = ""
Select Case Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 5)
Case "RAQUETTE"
strSql = "select count(P_IDRAQUETTE) from ASSOCIE where P_IDCAMPSENSA='" & Cells(i, 2) & "'"
Case "CORDAGE"
If Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 7) = "DIFFERENCE/SIMILITUDE" Then
strSql = "select (count(P_IDCORDPHYSIQ)+1)*4 from ESTIME where P_IDCAMPSENSA='" & Cells(i, 2) & "'"
Else
strSql = "select count(P_IDCORDPHYSIQ)*4 from ESTIME where P_IDCAMPSENSA='" & Cells(i, 2) & "'"
End If
Case "CHAUSSURE"
strSql = "select count(pch.F_ID_CHAUSSURE) from PAIRECHAUSSURE pch "
strSql = strSql & "inner join PAIRECHAUSSURE_CAMPSENS pchsensa on pchsensa.PAIRE_ID=pch.P_IDPAIRECHAUSSURE "
strSql = strSql & "inner join CAMPSENSA cpsensa on cpsensa.P_IDCAMPSENSA=pchsensa.CAMPAGNE_ID "
strSql = strSql & "where cpsensa.P_IDCAMPSENSA='" & Cells(i, 2) & "'"
End Select
'ouverture recorset
If strSql <> "" Then
Set rst = New ADODB.Recordset
rst.Open strSql, cnx
If rst.EOF Then
Set rst = Nothing
Else
'remplissage du tableau excel
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 9) = rst.Fields(0).Value
End If
End If
End If
Next i
[/COLOR]
'-----------------------------------------------------------------------------------
' liste de toutes les campagnes de tests au jeu DV accélérée non abandonnée
'-----------------------------------------------------------------------------------
strSql = ""
strSql = "select dv.P_IDDUREEVIEACC, dv.NOM, dv.CDSPORT, dv.CDPRODUIT, proj.LIBELLE, 'DV ACC' as Test,"
strSql = strSql & " dv.ETAT, dv.DTDEMANDE, dv.DTLIMITE, dv.DTCLOTURE from DUREEVIEACC dv"
strSql = strSql & " left join PROJET proj on proj.P_IDPROJET=dv.F_IDPROJET"
If Len(DateDebut) = 0 And Len(DateFin) = 0 Then
strSql = strSql & " where "
ElseIf Len(DateDebut) > 0 And Len(DateFin) = 0 Then
strSql = strSql & " where trunc(dv.DTCLOTURE)>='" & DateDebut & "' and"
ElseIf Len(DateDebut) > 0 And Len(DateFin) > 0 Then
strSql = strSql & " where trunc(dv.DTCLOTURE)>='" & DateDebut & "' and trunc(dv.DTCLOTURE)<='" & DateFin & "' and"
ElseIf Len(DateDebut) = 0 And Len(DateFin) > 0 Then
strSql = strSql & " where trunc(dv.DTCLOTURE)<='" & DateFin & "' and"
End If
strSql = strSql & " dv.ETAT<>'ABANDONNEE'"
strSql = strSql & " order by dv.P_IDDUREEVIEACC desc"
'ouverture recorset
Set rst = New ADODB.Recordset
rst.Open strSql, cnx
If rst.EOF Then
Set rst = Nothing
Else
'remplissage du tableau excel
While Not rst.EOF
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 2) = rst.Fields(0).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 3) = rst.Fields(1).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 4) = rst.Fields(2).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 5) = rst.Fields(3).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 6) = rst.Fields(4).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 7) = rst.Fields(5).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 10) = rst.Fields(6).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 11) = rst.Fields(7).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 12) = rst.Fields(8).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 13) = rst.Fields(9).Value
rst.MoveNext
k = k + 1
Wend
End If
'----------------------------------------------------------------------------------------------------------------------
' liste des campagnes de tests d'épreuve Cordage
'----------------------------------------------------------------------------------------------------------------------
strSql = ""
strSql = "select ser.P_IDSERIE, ser.NOM, ser.CDSPORT, 'CORDAGE' as Produit, pro.LIBELLE, 'LONGUE DUREE' as Test, 'CLOSE' as Etat, ser.DATECREATION, ser.DATECLOTURE from SERIE ser"
strSql = strSql & " inner join PROJET pro on pro.P_IDPROJET=ser.F_IDPROJET"
If Len(DateDebut) > 0 And Len(DateFin) = 0 Then
strSql = strSql & " where trunc(ser.DATECLOTURE)>='" & DateDebut & "'"
ElseIf Len(DateDebut) > 0 And Len(DateFin) > 0 Then
strSql = strSql & " where trunc(ser.DATECLOTURE)>='" & DateDebut & "' and trunc(ser.DATECLOTURE)<='" & DateFin & "'"
ElseIf Len(DateDebut) = 0 And Len(DateFin) > 0 Then
strSql = strSql & " where trunc(ser.DATECLOTURE)<='" & DateFin & "'"
End If
'ouverture recorset
Set rst = New ADODB.Recordset
rst.Open strSql, cnx
If rst.EOF Then
Set rst = Nothing
Else
'remplissage du tableau excel
While Not rst.EOF
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 2) = rst.Fields(0).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 3) = rst.Fields(1).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 4) = rst.Fields(2).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 5) = rst.Fields(3).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 6) = rst.Fields(4).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 7) = rst.Fields(5).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 10) = rst.Fields(6).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 11) = rst.Fields(7).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 13) = rst.Fields(8).Value
rst.MoveNext
k = k + 1
Wend
End If
'----------------------------------------------------------------------------------------------------------------------
' liste des campagnes de tests d'épreuve chaussure
'----------------------------------------------------------------------------------------------------------------------
strSql = ""
strSql = "select clgch.P_IDCAMPLONGDURCHA, clgch.NOM, clgch.SPORT, 'CHAUSSURE' as Produit, 'LONGUE DUREE' as Test, clgch.ETAT, clgch.DATECREATION, clgch.DATERETOURSOUHAITEE, clgch.DATECLOTURE from CAMPLONGCHAUSSURE clgch"
If Len(DateDebut) > 0 And Len(DateFin) = 0 Then
strSql = strSql & " where trunc(clgch.DATECLOTURE)>='" & DateDebut & "'"
ElseIf Len(DateDebut) > 0 And Len(DateFin) > 0 Then
strSql = strSql & " where trunc(clgch.DATECLOTURE)>='" & DateDebut & "' and trunc(clgch.DATECLOTURE)<='" & DateFin & "'"
ElseIf Len(DateDebut) = 0 And Len(DateFin) > 0 Then
strSql = strSql & " where trunc(clgch.DATECLOTURE)<='" & DateFin & "'"
End If
'ouverture recorset
Set rst = New ADODB.Recordset
rst.Open strSql, cnx
If rst.EOF Then
Set rst = Nothing
Else
'remplissage du tableau excel
While Not rst.EOF
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 2) = rst.Fields(0).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 3) = rst.Fields(1).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 4) = rst.Fields(2).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 5) = rst.Fields(3).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 7) = rst.Fields(4).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 10) = rst.Fields(5).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 11) = rst.Fields(6).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 12) = rst.Fields(7).Value
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 13) = rst.Fields(8).Value
rst.MoveNext
k = k + 1
Wend
End If
'[COLOR="#FF0000"]----------------------------------------------------------------------------------------------------------------------
' nombre de produits différents utilisés dans les campagnes de tests d'épreuve
' - Campagne cordages : nombre de cordages différents
' - Campagne chaussures : nombre de modèles différents
'----------------------------------------------------------------------------------------------------------------------
For i = 3 To Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Range("B1048576").End(xlUp).Row
If Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 7) = "LONGUE DUREE" Then
strSql = ""
Select Case Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 5)
Case "CORDAGE"
strSql = "select count(distinct(F_IDCORDPHYSIQ)) from ESSAI where F_IDSERIE='" & Cells(i, 2) & "'"
Case "CHAUSSURE"
strSql = "count(distinct(pch.F_ID_CHAUSSURE)) from CAMPLONGINFOCHAUSSURE cpinfoch"
strSql = strSql & " inner join PAIRECHAUSSURE pch on pch.P_IDPAIRECHAUSSURE=cpinfoch.F_IDPAIRECHAUSS"
strSql = strSql & " where F_IDCAMPLONGCHAUSS='" & Cells(i, 2) & "'"
End Select
'ouverture recorset
If strSql <> "" Then
Set rst = New ADODB.Recordset
rst.Open strSql, cnx
If rst.EOF Then
Set rst = Nothing
Else
'remplissage du tableau excel
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 8) = rst.Fields(0).Value
End If
End If
End If
Next i
'----------------------------------------------------------------------------------------------------------------------
' nombre de produits testés dans les campagnes de tests d'épreuve
' - Campagne cordages : nombre de raquettes cordées
' - Campagne chaussures : nombre de paires distribuées
'----------------------------------------------------------------------------------------------------------------------
For i = 3 To Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Range("B1048576").End(xlUp).Row
If Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 7) = "LONGUE DUREE" Then
strSql = ""
Select Case Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 5)
Case "CORDAGE"
strSql = "select count(P_IDMESUREESSAI) from MESUREESSAI mes"
strSql = strSql & " inner join ESSAI ess on ess.P_IDESSAI=mes.F_IDESSAI"
strSql = strSql & " inner join SERIE ser on ser.P_IDSERIE=ess.F_IDSERIE"
strSql = strSql & " where F_IDSERIE='" & Cells(i, 2) & "'"
Case "CHAUSSURE"
strSql = "select count(DATEDEBUTTEST) from CAMPLONGINFOCHAUSSURE where F_IDCAMPLONGCHAUSS='" & Cells(i, 2) & "'"
End Select
'ouverture recorset
If strSql <> "" Then
Set rst = New ADODB.Recordset
rst.Open strSql, cnx
If rst.EOF Then
Set rst = Nothing
Else
'remplissage du tableau excel
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(i, 9) = rst.Fields(0).Value
End If
End If
End If
Next i[/COLOR]
'----------------------------------------------------------------------------------------------------------------------
' nombre de raquettes cordées pour tests d'épreuve Tennis
'----------------------------------------------------------------------------------------------------------------------
strSql = ""
strSql = "select count(P_IDMESUREESSAI) from MESUREESSAI mes"
strSql = strSql & " inner join ESSAI ess on ess.P_IDESSAI=mes.F_IDESSAI"
strSql = strSql & " inner join SERIE ser on ser.P_IDSERIE=ess.F_IDSERIE"
If Len(DateDebut) > 0 And Len(DateFin) = 0 Then
strSql = strSql & " where trunc(DTCORDAGE)>='" & DateDebut & "'"
ElseIf Len(DateDebut) > 0 And Len(DateFin) > 0 Then
strSql = strSql & " where trunc(DTCORDAGE)>='" & DateDebut & "' and trunc(DTCORDAGE)<='" & DateFin & "'"
ElseIf Len(DateDebut) = 0 And Len(DateFin) > 0 Then
strSql = strSql & " where trunc(DTCORDAGE)<='" & DateFin & "'"
End If
strSql = strSql & " and ser.CDSPORT='TENNIS'"
'ouverture recorset
Set rst = New ADODB.Recordset
rst.Open strSql, cnx
If rst.EOF = False And rst.Fields(0).Value <> 0 Then
'remplissage du tableau excel
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 3) = "LD cordages"
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 4) = "TENNIS"
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 5) = "CORDAGE"
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 7) = "LONGUE DUREE"
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 9) = rst.Fields(0).Value
k = k + 1
End If
Set rst = Nothing
'----------------------------------------------------------------------------------------------------------------------
' nombre de raquettes cordées pour tests d'épreuve Bad
'----------------------------------------------------------------------------------------------------------------------
strSql = ""
strSql = "select count(P_IDMESUREESSAI) from MESUREESSAI mes"
strSql = strSql & " inner join ESSAI ess on ess.P_IDESSAI=mes.F_IDESSAI"
strSql = strSql & " inner join SERIE ser on ser.P_IDSERIE=ess.F_IDSERIE"
If Len(DateDebut) > 0 And Len(DateFin) = 0 Then
strSql = strSql & " where trunc(DTCORDAGE)>='" & DateDebut & "' and"
ElseIf Len(DateDebut) > 0 And Len(DateFin) > 0 Then
strSql = strSql & " where trunc(DTCORDAGE)>='" & DateDebut & "' and trunc(DTCORDAGE)<='" & DateFin & "' and"
ElseIf Len(DateDebut) = 0 And Len(DateFin) > 0 Then
strSql = strSql & " where trunc(DTCORDAGE)<='" & DateFin & "' and"
End If
strSql = strSql & " ser.CDSPORT='BADMINTON'"
'ouverture recorset
Set rst = New ADODB.Recordset
rst.Open strSql, cnx
If rst.EOF = False And rst.Fields(0).Value <> 0 Then
'remplissage du tableau excel
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 3) = "LD cordages"
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 4) = "BADMINTON"
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 5) = "CORDAGE"
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 7) = "LONGUE DUREE"
Workbooks(strNomFichier).Sheets(strNomFeuilleJeu).Cells(k, 9) = rst.Fields(0).Value
k = k + 1
End If
Set rst = Nothing
Application.ScreenUpdating = True
End Sub
Sub SelectionDateRequete()
Form_Indicateur.Show
End Sub