Discussion :

[amandon]

Bonjour à tous ,


je sais il y a plein de sujet sur ce thème mais c'est un peu spécifique

j'ai une macro vba "que je n'est pas conçu à l'origine" qui met à jour les informations d'un tableau à partir d'une requête allant cherché les informations dans un logiciel

avant tout était sur la même feuille excel mais pour des raisons pratique je l'ai diviser en plusieurs feuilles.

mais la macro était faite pour une seule feuille et ça beug .

j'ai essayer de faire une boucle for each mais je suis perdu en plus je ne veux pas mettre à jour toutes les feuilles ( 2 d'entre elle ne doivent pas etre concerné )

je vous ai mis le code en dessous qui marche très bien pour une feuille

Merci d'avance à tous

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
102
103
104
105
106
107
Sub maj()
 
    'i = 3
    'Do While Worksheets("Feuil1").Cells(i, 1).Value <> ""
    For i = 3 To Worksheets("Feuil1").UsedRange.Rows.Count
    'For i = 1050 To 1050
        If Worksheets("Feuil1").Cells(i, 1).Value <> "" Then
            If Worksheets("Feuil1").Cells(i, 2).Value = "" Then request "nusejour", i, 2
            If Worksheets("Feuil1").Cells(i, 14).Value = "" And Worksheets("Feuil1").Cells(i, 2).Value <> "" Then request "prescH", i, 14
            If Worksheets("Feuil1").Cells(i, 15).Value = "" And Worksheets("Feuil1").Cells(i, 2).Value <> "" Then request "prescB", i, 15
            If Worksheets("Feuil1").Cells(i, 16).Value = "" And Worksheets("Feuil1").Cells(i, 2).Value <> "" Then request "etab", i, 16
            If Worksheets("Feuil1").Cells(i, 17).Value = "" And Worksheets("Feuil1").Cells(i, 2).Value <> "" Then request "spe", i, 17
            If Worksheets("Feuil1").Cells(i, 18).Value = "" And Worksheets("Feuil1").Cells(i, 2).Value <> "" Then request "dated", i, 18
            If Worksheets("Feuil1").Cells(i, 19).Value = "" And Worksheets("Feuil1").Cells(i, 2).Value <> "" Then request "site", i, 19
            If Worksheets("Feuil1").Cells(i, 20).Value = "" Then request "etabBiomol", i, 20
            If Worksheets("Feuil1").Cells(i, 3).Value = "" Then request "sstrait", i, 3
        End If
        'i = i + 1
    'Loop
    Next i
 
'    For i = 3 To ActiveSheet.UsedRange.Rows.Count
'    'For i = 289 To 289
'        'If Cells(i, 21).Value = "" Then
'            If Cells(i, 1).Value = "" Then Exit For
'            If Cells(i, 2).Value = "" Then request "presc", i, 2
'            If Cells(i, 3).Value = "" Then request "etab", i, 3
'            If Cells(i, 11).Value = "" Then request "datrecept", i, 11
'            If Cells(i, 12).Value = "" Then request "nusejour", i, 12
'            If Cells(i, 19).Value = "" Then request "datsais", i, 19
'            If Cells(i, 20).Value = "" Then request "datval", i, 20
'            If Cells(i, 21).Value = "" Then request "dated", i, 21
'        'End If
'    Next i
End Sub
Sub request(param As String, ByVal indice As Integer, col As Integer)
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim req As String
    Dim i As Long
 
    Set cn = New ADODB.Connection
    Set rs = New ADODB.Recordset
 
    cn.Open "DSN=Test;UID=diamic;PWD=cs"
 
    If param = "nusejour" Then
        req = "select upper(nusejour) from demande where nuddeext = '" & Worksheets("Feuil1").Cells(indice, 1).Value & "'"
    ElseIf param = "prescH" Then
        req = "select nommed from demande, medecin where demande.nupresc = medecin.numed and nuddeext = '" & Worksheets("Feuil1").Cells(indice, 2).Value & "'"
    ElseIf param = "prescB" Then
        req = "select nommed from demande, medecin where demande.nupresc = medecin.numed and nuddeext = '" & Worksheets("Feuil1").Cells(indice, 1).Value & "'"
    ElseIf param = "etab" Then
        req = "select nomorig from demande, origine where demande.nuorig = origine.nuorig and nuddeext = '" & Worksheets("Feuil1").Cells(indice, 2).Value & "'"
    ElseIf param = "spe" Then
        req = "select nomlisteref from listeref, medecin, demande where listeref.codlisteref = medecin.codspecialite and typliste = 'SPE' and medecin.numed = demande.nupresc and nuddeext = '" & Worksheets("Feuil1").Cells(indice, 2).Value & "'"
    ElseIf param = "dated" Then
        req = "select min(datedition) from demande, resultat where demande.nudde = resultat.nudde and nuddeext = '" & Worksheets("Feuil1").Cells(indice, 2).Value & "'"
    ElseIf param = "site" Then
        req = "select nomexploit from demande, secteur, exploitant where demande.codsecteur = secteur.codsecteur and secteur.nuexploit = exploitant.nuexploit and nuddeext = '" & Worksheets("Feuil1").Cells(indice, 2).Value & "'"
    ElseIf param = "etabBiomol" Then
        req = "select adresse1 from demande, medecin where nupresc = numed and nuddeext = '" & Worksheets("Feuil1").Cells(indice, 1).Value & "'"
    ElseIf param = "sstrait" Then
        req = "select nomorig from demande, origine where origine.nuorig = demande.nuorig and nuddeext = '" & Worksheets("Feuil1").Cells(indice, 1).Value & "'"
    End If
 
 
'    If param = "presc" Then
'        req = "select nommed from demande, medecin where demande.nupresc = medecin.numed and nuddeext = '" & Cells(indice, 1).Value & "'"
'    ElseIf param = "etab" Then
'        req = "select nomorig from demande, origine where demande.nuorig = origine.nuorig and nuddeext = '" & Cells(indice, 1).Value & "'"
'    ElseIf param = "datrecept" Then
'        req = "select datheurreception from demande where nuddeext = '" & Cells(indice, 1).Value & "'"
'    ElseIf param = "nusejour" Then
'        req = "select nusejour from demande where nuddeext = '" & Cells(indice, 1).Value & "'"
'    ElseIf param = "datsais" Then
'        If Cells(indice, 1) Like "*UE*" Then
'            req = "select * from (select datsaiscr from resultat, demande where demande.nudde = resultat.nudde and scrinvalide is null and nuddeext = '" & Cells(indice, 1).Value & "' order by nures desc) tmp0 where rownum <= 1"
'        ElseIf Cells(indice, 1) Like "*UM*" And Cells(indice, 12).Value <> "" Then
'            req = "select resultat.datsaiscr from resultat, demande where resultat.nudde = demande.nudde and demande.nuddeext = '" & Cells(indice, 12).Value & "' and resultat.nulec2 in (794,810)"
'        End If
'    ElseIf param = "datval" Then
'        If Cells(indice, 1) Like "*UE*" Then
'            req = "select * from (select datvalidation from resultat, demande where demande.nudde = resultat.nudde and scrinvalide is null and nuddeext = '" & Cells(indice, 1).Value & "' order by nures desc) tmp0 where rownum <= 1"
'        ElseIf Cells(indice, 1) Like "*UM*" And Cells(indice, 12).Value <> "" Then
'            req = "select resultat.datvalidation from resultat, demande where resultat.nudde = demande.nudde and demande.nuddeext = '" & Cells(indice, 12).Value & "' and resultat.nulec2 in (794,810)"
'        End If
'    ElseIf param = "dated" Then
'        If Cells(indice, 1) Like "*UE*" Then
'            req = "select * from (select datedition from resultat, demande where demande.nudde = resultat.nudde and scrinvalide is null and nuddeext = '" & Cells(indice, 1).Value & "' order by nures desc) tmp0 where rownum <= 1"
'        ElseIf Cells(indice, 1) Like "*UM*" And Cells(indice, 12).Value <> "" Then
'            req = "select resultat.datedition from resultat, demande where resultat.nudde = demande.nudde and demande.nuddeext = '" & Cells(indice, 12).Value & "' and resultat.nulec2 in (794,810)"
'        End If
'    End If
    rs.Open req, cn
    If Not (rs.EOF) Then
        Worksheets("Feuil1").Cells(indice, col).CopyFromRecordset rs
    Else
        Worksheets("Feuil1").Cells(indice, col).Value = "n° histo non valide"
    End If
    rs.Close
    req = Empty
 
    cn.Close
    Set rs = Nothing
    Set cn = Nothing
End Sub

[ARTURO83]

Bonjour,

Essayez ceci:

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
Sub maj()
    Dim f As Long, i As Long
    Dim f1 As Worksheet
    For f = 1 To Sheets.Count 'on passe toutes les feuilles en revue
        If Sheets(f).Name <> "Feuil1" And Sheets(f).Name <> "Feuil2" Then 'toutes les feuille sauf feuil1 et feuil2
            Set f1 = Sheets(Sheets(f).Name)
            For i = 3 To Sheets(f).UsedRange.Rows.Count
                If f1.Cells(i, 1).Value <> "" Then
                    If f1.Cells(i, 2).Value = "" Then request "nusejour", i, 2
                    If f1.Cells(i, 14).Value = "" And f1.Cells(i, 2).Value <> "" Then request "prescH", i, 14
                    If f1.Cells(i, 15).Value = "" And f1.Cells(i, 2).Value <> "" Then request "prescB", i, 15
                    If f1.Cells(i, 16).Value = "" And f1.Cells(i, 2).Value <> "" Then request "etab", i, 16
                    If f1.Cells(i, 17).Value = "" And f1.Cells(i, 2).Value <> "" Then request "spe", i, 17
                    If f1.Cells(i, 18).Value = "" And f1.Cells(i, 2).Value <> "" Then request "dated", i, 18
                    If f1.Cells(i, 19).Value = "" And f1.Cells(i, 2).Value <> "" Then request "site", i, 19
                    If f1.Cells(i, 20).Value = "" Then request "etabBiomol", i, 20
                    If f1.Cells(i, 3).Value = "" Then request "sstrait", i, 3
                End If
            Next i
        End If
    Next f
End Sub

A la ligne

Code :

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

 If Sheets(f).Name <> "Feuil1" And Sheets(f).Name <> "Feuil2" Then 'toutes les feuille sauf feuil1 et feuil2

Remplacez "Feuil1" et "Feuil2" par les noms des feuilles à exclure.

Cdlt

[amandon]

Bonjour,

Merci beaucoup déjà il n'y a pas de beug sur cette partie la mais il me manque le deuxieme sub car c'est lui qui est la requete et pour l'instant que sur 1 feuille.

merci d'avance

[ARTURO83]

mais il me manque le deuxieme sub car c'est lui qui est la requete et pour l'instant que sur 1 feuille.

Je vous ai simplement modifié la macro "Maj" (que vous devez mettre à la place de celle existante) pour passer toutes les feuilles en revue (c'est ce qui était demandé), je n'ai pas touché la seconde macro "Request".
Pour une question de lisibilité, j'ai supprimé toutes les lignes en commentaire dans la macro "Maj"

Cdlt

[amandon]

justement cette requête s'applique sur chque feuille du sub d'en haut . si vous regarder pouvez vous m'aidez sur ce point la s'il vous plaît.

[ARTURO83]

Bonjour,

Alors essayez ceci, mais je ne peux pas le tester.
le principe : remplacement de tous les "Worksheets("Feuil1")" par la variable f1

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
 
Dim f1 As Worksheet
Dim f As Long
 
Sub maj()
    Dim i As Long
    For f = 1 To Sheets.Count 'on passe toutes les feuilles en revue
        If Sheets(f).Name <> "Feuil1" And Sheets(f).Name <> "Feuil2" Then 'toutes les feuille sauf feuil1 et feuil2
            Set f1 = Sheets(Sheets(f).Name)
            For i = 3 To Sheets(f).UsedRange.Rows.Count
                If f1.Cells(i, 1).Value <> "" Then
                    If f1.Cells(i, 2).Value = "" Then request "nusejour", i, 2
                    If f1.Cells(i, 14).Value = "" And f1.Cells(i, 2).Value <> "" Then request "prescH", i, 14
                    If f1.Cells(i, 15).Value = "" And f1.Cells(i, 2).Value <> "" Then request "prescB", i, 15
                    If f1.Cells(i, 16).Value = "" And f1.Cells(i, 2).Value <> "" Then request "etab", i, 16
                    If f1.Cells(i, 17).Value = "" And f1.Cells(i, 2).Value <> "" Then request "spe", i, 17
                    If f1.Cells(i, 18).Value = "" And f1.Cells(i, 2).Value <> "" Then request "dated", i, 18
                    If f1.Cells(i, 19).Value = "" And f1.Cells(i, 2).Value <> "" Then request "site", i, 19
                    If f1.Cells(i, 20).Value = "" Then request "etabBiomol", i, 20
                    If f1.Cells(i, 3).Value = "" Then request "sstrait", i, 3
                End If
            Next i
        End If
    Next f
    Set f1 = Nothing
End Sub
 
Sub request(param As String, ByVal indice As Integer, col As Integer)
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim req As String
    Dim i As Long
 
    Set cn = New ADODB.Connection
    Set rs = New ADODB.Recordset
 
    cn.Open "DSN=Test;UID=diamic;PWD=cs"
 
    If param = "nusejour" Then
        req = "select upper(nusejour) from demande where nuddeext = '" & f1.Cells(indice, 1).Value & "'"
    ElseIf param = "prescH" Then
        req = "select nommed from demande, medecin where demande.nupresc = medecin.numed and nuddeext = '" & f1.Cells(indice, 2).Value & "'"
    ElseIf param = "prescB" Then
        req = "select nommed from demande, medecin where demande.nupresc = medecin.numed and nuddeext = '" & f1.Cells(indice, 1).Value & "'"
    ElseIf param = "etab" Then
        req = "select nomorig from demande, origine where demande.nuorig = origine.nuorig and nuddeext = '" & f1.Cells(indice, 2).Value & "'"
    ElseIf param = "spe" Then
        req = "select nomlisteref from listeref, medecin, demande where listeref.codlisteref = medecin.codspecialite and typliste = 'SPE' and medecin.numed = demande.nupresc and nuddeext = '" & f1.Cells(indice, 2).Value & "'"
    ElseIf param = "dated" Then
        req = "select min(datedition) from demande, resultat where demande.nudde = resultat.nudde and nuddeext = '" & f1.Cells(indice, 2).Value & "'"
    ElseIf param = "site" Then
        req = "select nomexploit from demande, secteur, exploitant where demande.codsecteur = secteur.codsecteur and secteur.nuexploit = exploitant.nuexploit and nuddeext = '" & f1.Cells(indice, 2).Value & "'"
    ElseIf param = "etabBiomol" Then
        req = "select adresse1 from demande, medecin where nupresc = numed and nuddeext = '" & f1.Cells(indice, 1).Value & "'"
    ElseIf param = "sstrait" Then
        req = "select nomorig from demande, origine where origine.nuorig = demande.nuorig and nuddeext = '" & f1.Cells(indice, 1).Value & "'"
    End If
    rs.Open req, cn
    If Not (rs.EOF) Then
        f1.Cells(indice, col).CopyFromRecordset rs
    Else
        f1.Cells(indice, col).Value = "n° histo non valide"
    End If
    rs.Close
    req = Empty
 
    cn.Close
    Set rs = Nothing
    Set cn = Nothing
End Sub

Cdlt