Exécution code

Sly le globe trotter · 9 Septembre 2015

Bonjour à tous,

Je rencontre actuellement quelques difficultés avec un fichier contenant des macros alors que ce dernier fonctionnait il y a peu... Peut être pourrez-vous éclairer mes lanternes

Dans un fichier Excel, je dispose de macros me permettant de faire des requêtes sur une base Oracle et de rapatrier ces données sous Excel.

Depuis peu, une partie de ces macros ne me renvoient plus de résultats... En revanche, si j’exécute le code pas à pas, toutes les valeurs me sont bien renvoyées. Auriez-vous une idée de ce qui pourrait provoquer ce dysfonctionnement ?

D'avance merci pour votre aide,
Sylvain

mutzik · 9 Septembre 2015

Re : Exécution code

bonjour,

cela m'est arrivé, et était du à un changement du nom de deux champs dans ma base SQL, gérée par un fournisseur externe qui prend la main sur mes équipements ...
que ce soit SQL ou Oracle ou ... ce sont toujours des requêtes qu'on lance vers le moteur de base de données et si la requête ne contient pas les bons termes, au mieux elle renvoie un recordset vide sinon un message d'erreur

Sly le globe trotter · 9 Septembre 2015

Re : Exécution code

Bonjour mutzik et merci pour ta réponse,

Le fait est que si j’exécute le code pas à pas, cela fonctionne donc je me dis que les requêtes sont bonnes. Qu'en penses-tu ?

mutzik · 9 Septembre 2015

Re : Exécution code

re, oui mais ma boule de cristal n'arrive pas à trouver ton code ...

Sly le globe trotter · 9 Septembre 2015

Re : Exécution code

Le fichier est relativement volumineux... Je me demandais si je n'étais pas passer à côté de quelque chose d'évident étant donné que tout fonctionnait auparavant.

Voici le module incriminé

Code:

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

Les parties du code ne fonctionnant qu'en pas à pas sont

nombre de produits utilisés dans les campagnes de tests au jeu Produit, Sensoriel et différence/similitude non abandonnées
nombre de produits différents utilisés dans les campagnes de tests d'épreuve

Effectuez une recherche sur Excel Downloads...

Exécution code

Sly le globe trotter

XLDnaute Occasionnel

mutzik

XLDnaute Barbatruc

Sly le globe trotter

XLDnaute Occasionnel

mutzik

XLDnaute Barbatruc

Sly le globe trotter

XLDnaute Occasionnel

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums