Discussion :

[amelyfred]

Bonjour,
J'ai créé ce bout de code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
 
  Dim Demandeur As String
    Dim Service As String
    Dim Date_Enregistrement As Date
    Dim Projet As String
    Dim N_Enregistrement As Long
    Dim Ma_Var As Variant
    Dim Analyse_1 As Variant
    Dim Analyse_2 As Variant
    Dim Analyse_3 As Variant
    Dim Analyse_4 As Variant
    Dim Analyse_5 As Variant
    Dim Analyse_6 As Variant
    Dim Analyse_7 As Variant
    Dim Analyse_8 As Variant
    Dim Analyse_9 As Variant
    Dim Analyse_10 As Variant
    Dim Cell_ref As Range
    Dim N_Ligne As Long
    Dim Ma_Select_2 As Range
 
 
 
'Procédure permettant de récupérer toutes les données pour le transfert dans le fichier base
 
Public Sub Recup_Donnees()
 Demandeur = Range("C4").Value
    Service = Range("C5").Value
    Date_Enregistrement = Range("C7").Value
    Projet = Range("C6").Value
    Analyse_1 = ""
    Analyse_2 = ""
    Analyse_3 = ""
    Analyse_4 = ""
    Analyse_5 = ""
    Analyse_6 = ""
    Analyse_7 = ""
    Analyse_8 = ""
    Analyse_9 = ""
    Analyse_10 = ""
 
 
For Each Cell_ref In Range("Reference")
    If Cell_ref.Value <> "" Then
        N_Ligne = Cell_ref.Row
        Call Recup_Analyse
        Call Enregistremen_Base
    End If
Next Cell_ref
 
 
End Sub
 
Public Sub Recup_Analyse()
 
 'Sélection de la plage pour vérification des analyses demandées
 
 Set Ma_Select_2 = Sheets("Formulaire").Range("D" & N_Ligne & ": M" & N_Ligne)
 i = 1
 
 For Each Cell In Ma_Select_2
    If Cell.Value = "O" Then
       N_Col = Cell.Column
 
      Select Case i
        Case 1
            Analyse_1 = Range(Cells(4, N_Col)).Value
 
       Case 2
            Analyse_2 = Range(Cells(4, N_Col)).Value
 
        Case 3
            Analyse_3 = Range(Cells(4, N_Col)).Value
 
        Case 4
            Analyse_4 = Range(Cells(4, N_Col)).Value
 
        Case 5
            Analyse_5 = Range(Cells(4, N_Col)).Value
 
        Case 6
            Analyse_6 = Range(Cells(4, N_Col)).Value
 
        Case 7
            Analyse_7 = Range(Cells(4, N_Col)).Value
 
        Case 8
            Analyse_8 = Range(Cells(4, N_Col)).Value
 
        Case 9
            Analyse_9 = Range(Cells(4, N_Col)).Value
 
        Case 10
            Analyse_10 = Range(Cells(4, N_Col)).Value
    End Select
       i = i + 1
    End If
Next Cell
 
 
End Sub

mais je ne comprends pas 2 choses :
- tout d'abord, il ne veut pas que je mette mes variable Analyse_1,... en tant que variable String : Pourquoi??

-Lorsque je lance le code, ca commence bien car je récupère bien ma première valeur Analyse_1 mais la seconde boucle message d'erreur "La méthode 'Range' de l'objet '_Global' a échoué "

Pourquoi d'après vous?
Merci d'avance
Fred

[mercatog]

Pour ta question 2

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Public Sub Recup_Analyse()
Dim i As Long
'Sélection de la plage pour vérification des analyses demandées
 
With Sheets("Formulaire")
    Set Ma_Select_2 = .Range("D" & N_Ligne & ": M" & N_Ligne)
    i = 1
    For Each Cell In Ma_Select_2
        If Cell.Value = "O" Then
            N_Col = Cell.Column
            Select Case i
                Case 1
                    Analyse_1 = .Cells(4, N_Col).Value
                Case 2
                    Analyse_2 = .Cells(4, N_Col).Value
                'la suite
            End Select
            i = i + 1
        End If
    Next Cell
    'Set Ma_Select_2 = Nothing
End With
End Sub

PS: Un Range n'indiquant pas sa feuille mère c'est de la peste dans un code.

PS2: Peut être il serait plus judicieux de travailler, dans ton cas, à l'aide d'un tableau au lieu des variables Analyse_x et avec des procédures paramétrées au lie des variables publiques. Bon c'est une suggestion que tu peux ignorer.

[amelyfred]

Merci de ton aide mais ca ne fonctionne pas mieux.

Je vais essayer d'étudier l'histoire des tableau mais je suis assez novice en vba et je me débrouille un peu comme je peux.

[mercatog]

ca ne fonctionne pas mieux

ne veut rien dire.

essaies de mettre tout ton code avec notamment (en plus) ta subEnregistremen_Base
et en expliquant les feuilles avec lesquelles tu travaille. (Description de ton classeur)

[amelyfred]

Voilà je mets le fichier en pieces jointes ca sera plus simple.
L'idée est de faire une demande d'analyse.
Le personne choisit un produit et les différents noms d'analyses s'affichent.

Ensuit la personne entre un numéro d'échantillon et choisit par O ou N si elle souhaite l'analyse du produit.

Ce que je souhaite faire c'est d'envoyer vers un autre fichier le nom de l'échantillons et les analyses demandées (cad où le "O" est sélectionnées).
C'est là où je bloque.

Mon idée était :
dans ma sélection Référence, je récupère toutes les cellules remplies puis je regarde pour chaque ligne, quelles sont les cellules où "O" est sélectionné puis je récupère dans une variable "Analyse_x" le nome de l'analyse et j'envoie le tout dans mon autre fichier.


Il y a peut etre plus simple à faire.
Qu'en pensez vous?
Merci d'avance pour votre aide
Fred

[mercatog]

Je n'ai pas ton fichier vers lequel exporter mais teste cette première proposition (Aucune variable globale)

Peux être tu auras un problème dans la ligne 66

Teste en pas à pas (F8)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
Option Explicit
 
'Procédure permettant de récupérer toutes les données pour le transfert dans le fichier base
Sub Recup_Donnees()
Dim Demandeur As String, Service As String, Projet As String
Dim Date_Enregistrement As Date
Dim c As Range
 
With Sheets("Formulaire")
    Demandeur = .Range("C4").Value
    Service = .Range("C5").Value
    Date_Enregistrement = .Range("C7").Value
    Projet = .Range("C6").Value
    For Each c In .Range("Reference")
        If c.Value <> "" Then Call Enregistremen_Base(Date_Enregistrement, Demandeur, Service, Projet, Recup_Analyse(c.Row))
    Next c
End With
End Sub
 
Function Recup_Analyse(ByVal Lig As Long) As String
Dim c As Range
Dim Tablo() As String
Dim Res As String
 
With Sheets("Formulaire")
    ReDim Tablo(1 To 10)
    For Each c In .Range("D" & Lig & ": M" & Lig)
        If c.Value = "O" Then Tablo(c.Column - 3) = .Cells(4, c.Column)  '-3 on commence en colonne D=4
    Next c
End With
Res = Join(Tablo, "','")
'ICI ON PEUT FAIRE AUTREMENT POUR N'AVOIR QUE LES RESULTATS NON VIDES
Recup_Analyse = Res
End Function
 
'Procédure permettant de faire l'enregistrement des différentes données dans le fichhier base
 
Sub Enregistremen_Base(ByVal DteEnrg As Date, ByVal Dem As String, ByVal Serv As String, ByVal Proj As String, ByVal Analys As String)
Dim Cn As New ADODB.Connection
Dim Rst As ADODB.Recordset
Dim Fichier As String, Feuille As String, strSQL As String
Dim NumEnrg As Long
 
'Définit le classeur fermé servant de base de données
Fichier = "P:\commun\Techniciens\F.ROLLIN\divers\Proj_DA\Base_Donnees_DA.xls"
'Nom de la feuille dans le classeur fermé
Feuille = "Base"
 
'--- Connexion ---
With Cn
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
                        & Fichier & ";Extended Properties=""Excel 12.0;HDR=YES;"""
    .Open
End With
'-----------------
'Définit la requête permettant de récupérer le dernier numéro d'enregistrement
strSQL = "SELECT Max([NumEnrg]) FROM [" & Feuille & "$]"
Set Rst = New ADODB.Recordset
Set Rst = Cn.Execute(strSQL)
 
NumEnrg = Rst(0) + 1
'--------------------------------------------------------
'Définit la requête permettant d'écrire toutes les données.
 
strSQL = "INSERT INTO [" & Feuille & "$] " & "VALUES (" & "'" & NumEnrg & "', " & "'" & DteEnrg & "', " & "'" & Dem & "',  " & "'" & Serv & "'," & "'" & Proj & "'," & "'" & Analys & "')"
Cn.Execute strSQL
 
'--- Fermeture connexion ---
Cn.Close
Set Cn = Nothing
End Sub

EDIT
Remplace dans la ligne 58, NumEnrg par le nom du champs de ta feuille Base. Et seulement dans cette ligne.

[amelyfred]

Ecoute ca fait presque ce que je souhaitais.
Effectivement je souhaiterais récupérer seulement les résultats non vides. QUe peux tu me proposer?
Bon je suis un peu chiant
Merci de ton aide.
Et dire que je galère depuis 3 jours sur ce trucs alors que tun me sors ca en 3 minutes.
Merci d'avance
FRED

[mercatog]

As tu testé le nouveau code? j'avais édité et fais une remarque.
Je pars maintenant, plus tard je regarderai.

[amelyfred]

J'avais pas vu ta réponse mais j'avais rectifié et ca fonctionne très bien.
Il faut juste que je modifie pour récupérer seulement les résultats non vides. J'attends ton aide.
Merci encore.
Fred

[mercatog]

Afin de ne pas à chaque boucle, ouvrir la connexion, transférer les données et fermer la connexion, ci-joint amélioration du code pour que la connexion sera ouverte une seule fois et la boucle permet d'écrire les données de chaque ligne

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
Option Explicit
 
Function Recup_Analyse(ByVal Lig As Long) As String
Dim Res As String, St As String, Dem As String, Serv As String, Proj As String
Dim DteEnrg As Date
Dim c As Range
 
With Sheets("Formulaire")
    Dem = .Range("C4").Value
    Serv = .Range("C5").Value
    Proj = .Range("C6").Value
    DteEnrg = CDate(.Range("C7").Value)
 
    Res = "',#" & DteEnrg & "#,'" & Dem & "','" & Serv & "','" & Proj
    For Each c In .Range("D" & Lig & ": M" & Lig)
        If c.Value = "O" Then St = .Cells(4, c.Column).Value
        Res = Res & "','" & St
        St = vbNullString
    Next c
End With
Recup_Analyse = Res
End Function
 
'Procédure permettant de faire l'enregistrement des différentes données dans le fichhier base
Sub Enregistremen_Base()
Dim Cn As New ADODB.Connection
Dim Rst As New ADODB.Recordset
Dim Fichier As String, Feuille As String, strSQL As String
Dim NumEnrg As Long
Dim c As Range
 
'Définit le classeur fermé servant de base de données
Fichier = "P:\commun\Techniciens\F.ROLLIN\divers\Proj_DA\Base_Donnees_DA.xls"
'Nom de la feuille dans le classeur fermé
Feuille = "Base"
'--- Connexion ---
With Cn
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
                        & Fichier & ";Extended Properties=""Excel 12.0;HDR=YES;"""
    .Open
End With
'-----------------
'Définit la requête permettant de récupérer le dernier numéro d'enregistrement
strSQL = "SELECT Max([N_Enregistrement]) FROM [" & Feuille & "$]"
Set Rst = Cn.Execute(strSQL)
NumEnrg = IIf(IsNull(Rst(0)), 0, Rst(0))
Set Rst = Nothing
 
With Sheets("Formulaire")
    For Each c In .Range("Reference")
        If c.Value <> "" Then
            'Définit la requête permettant d'écrire toutes les données.
            NumEnrg = NumEnrg + 1
            strSQL = "INSERT INTO [" & Feuille & "$] VALUES ('" & NumEnrg & Recup_Analyse(c.Row) & "')"
            Cn.Execute strSQL
        End If
    Next c
End With
'--- Fermeture connexion ---
Cn.Close
Set Cn = Nothing
End Sub

[amelyfred]

Merci à toi mercatog,
Ca fonctionne bien sauf que le code éxécute la ligne 17 même si la cellule ne contient pas la valeurs "O". Je ne voudrais pas cela car du coup j'ai des blanc entre les valeurs.

En fait on dirait que les lignes 17 et 18 ne font pas partie du bloc If

Oublie, j'ai ajouté End If et ca focntionne très bien.
Encore Merci

Ah j'ai parlé trop vite!!
Du coup il me dit que le nombre de valeurs de la requete doit coincider avec le nombre de champs!!!

Du coup j'ai modifié un peu la fonction et ca fonctionne.
Est ce que vous pensez qu'il y avait plus simple?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
 
 
Function Recup_Analyse(ByVal Lig As Long) As String
Dim Res As String, St As String, Dem As String, Serv As String, Proj As String, Ech As String, NLot As String
Dim DteEnrg As Date
Dim c As Range
 
 
 
With Sheets("Formulaire")
    Dem = .Range("C4").Value
    Serv = .Range("C5").Value
    Proj = .Range("C6").Value
    DteEnrg = CDate(.Range("C7").Value)
    Ech = .Range("B" & Lig).Value
    NLot = .Range("C" & Lig).Value
 
    Res = "',#" & DteEnrg & "#,'" & Dem & "','" & Serv & "','" & Proj & "','" & Ech & "','" & NLot
    For Each c In .Range("D" & Lig & ": M" & Lig)
        If c.Value = "O" Then
            St = .Cells(4, c.Column).Value
            Res = Res & "','" & St
            St = vbNullString
        End If
 
    Next c
    For Each c In .Range("D" & Lig & ": M" & Lig)
        If c.Value <> "O" Then
            St = ""
            Res = Res & "','" & St
            St = vbNullString
        End If
 
    Next c
End With
Recup_Analyse = Res
End Function

Merci d'avance
Fred

[mercatog]

Bonjour
Voila ma proposition

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
Option Explicit
 
Function Recup_Analyse(ByVal Lig As Long) As String
Dim Res As String, St As String, Dem As String, Serv As String, Proj As String
Dim DteEnrg As Date
Dim c As Range
Dim i As Byte
 
With ThisWorkbook.Sheets("Formulaire")
    Dem = .Range("C4").Value
    Serv = .Range("C5").Value
    Proj = .Range("C6").Value
    DteEnrg = CDate(.Range("C7").Value)
 
    Res = "',#" & DteEnrg & "#,'" & Dem & "','" & Serv & "','" & Proj
    For Each c In .Range("D" & Lig & ": M" & Lig)
        If c.Value = "O" Then
            Res = Res & "','" & .Cells(4, c.Column).Value
            i = i + 1
        End If
    Next c
End With
St = Application.Rept("','", 11 - i)
St = Left(St, Len(St) - 3)
Recup_Analyse = Res & St
End Function
 
'Procédure permettant de faire l'enregistrement des différentes données dans le fichhier base
Sub Enregistremen_Base()
Dim Cn As New ADODB.Connection
Dim Rst As New ADODB.Recordset
Dim Fichier As String, Feuille As String, strSQL As String
Dim NumEnrg As Long
Dim c As Range
 
'Définit le classeur fermé servant de base de données
Fichier = "P:\commun\Techniciens\F.ROLLIN\divers\Proj_DA\Base_Donnees_DA.xls"
'Fichier = "C:\Documents and Settings\Administrateur\Bureau\Base_Donnees_DA.xls"
'Nom de la feuille dans le classeur fermé
Feuille = "Base"
'--- Connexion ---
With Cn
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
                        & Fichier & ";Extended Properties=""Excel 12.0;HDR=YES;"""
    .Open
End With
'-----------------
'Définit la requête permettant de récupérer le dernier numéro d'enregistrement
strSQL = "SELECT Max([N_Enregistrement]) FROM [" & Feuille & "$]"
Set Rst = Cn.Execute(strSQL)
NumEnrg = IIf(IsNull(Rst(0)), 0, Rst(0))
Set Rst = Nothing
 
With ThisWorkbook.Sheets("Formulaire")
    For Each c In .Range("Reference")
        If c.Value <> "" Then
'Définit la requête permettant d'écrire toutes les données.
            NumEnrg = NumEnrg + 1
            strSQL = "INSERT INTO [" & Feuille & "$] VALUES ('" & NumEnrg & Recup_Analyse(c.Row) & "')"
            Cn.Execute strSQL
        End If
    Next c
End With
'--- Fermeture connexion ---
Cn.Close
Set Cn = Nothing
End Sub

[amelyfred]

Merci bien