Code VBA qui fonctionne bien pour un INSERT mais pas plusieurs en même temps

Version imprimable

1 pièce(s) jointe(s)

Bonjour,

Je viens vous voir car je viens de voir qu'il y avais un problème sur mon application, je vais déjà vous mettre mon code puis je vous expliquerai.

Code:

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
Private Sub Exporter_Click()
 
Dim base As Database
Dim SQL As String
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strSql As String
Dim Valeur As String
Dim test
Dim extraitD As Variant
 
Dim extraitG As Variant
 
 
 
 
 
Set base = Application.CurrentDb
 
 
 
             LongueurCh = Right([NumArticle], 4)
 
 
                 Set dbs = CurrentDb
 
                strSql = "SELECT * FROM Commande " _
                & " WHERE Selection = True "
 
                Set rst = dbs.OpenRecordset(strSql, dbOpenDynaset)
 
                extraitD = Right(rst.Fields("NumArticle"), 6)
                extraitG = Left(rst.Fields("NumArticle"), InStr(rst.Fields("NumArticle"), extraitD) - 1)
 
 
 
                RefLaq = Left([extraitD], 2)
                'MsgBox (Laquage)
 
 
 
 
 
             CurrentDb.Execute "UPDATE Commande " & _
                               "SET Commande.Laquage = '" & RefLaq & "'  Where Selection=True ;"
 
 
             test = DLookup("[PoidsTH]", "base", "[Référence] = '" & extraitG & "' ")
 
             CurrentDb.Execute "UPDATE Commande " & _
                               "SET Commande.PoidsTH = '" & test & "' Where Selection=True ;"
           ' MsgBox (test)
 
 
 
 
             CurrentDb.Execute "UPDATE Commande " & _
                               "SET Commande.Ref =  '" & extraitG & "'  Where Selection=True ;"
 
 
 
             CurrentDb.Execute "UPDATE Commande " & _
                               "SET Commande.Longueur = " & LongueurCh & " Where Selection=True ;"
 
 
            Filière = DLookup("[Filiere]", "Feuil2", "[Référence] = '" & extraitG & "' ")
            CurrentDb.Execute "UPDATE Commande " & _
                              "SET Commande.NumFiliere= '" & Filière & "' Where Selection=True ;"
 
 
 
 
 
           '  CurrentDb.Execute SQL
 
 
 
DoCmd.RunSQL " INSERT INTO EnAttPlanification(NumOrigine,Numero,NumArticle,CodeVariante,DateCommande,DateLivDemander,QteManquante,QteRestante,QtePretDepart,PoidsManquant,Observations,NomDestinataire,NumDestination,Qte,Longueur,Ref,PoidsTH,Laquage,NumFiliere) " & _
             "SELECT   Commande.NumOrigine, Commande.Numero, Commande.NumArticle, Commande.CodeVariante, Commande.DateCommande, Commande.DateLivDemander, Commande.QteManquante, Commande.QteRestante, Commande.QtePretDepart, Commande.PoidsManquant, Commande.Observations, Commande.NomDestinataire, Commande.NumDestination, Commande.Qte, Commande.Longueur, Commande.Ref, Commande.PoidsTH, Commande.Laquage, Commande.NumFiliere  " & _
              "FROM Commande " & _
              "WHERE Selection=-1;"
 
DoCmd.RunSQL " DELETE FROM Commande " & _
             " WHERE Selection=-1;"
 
 
 
 
base.Close
 
Me.Requery
Me.Refresh
 
 
 
End Sub

Pour vous expliquer lorsque que je clique sur le bouton Exporter (le code de ce couton ci-dessus) je découpe des champs (NumArticle) afin de n'avoir que certaine partie comme Longueur,RefLaq ...
Seul problème sur ces deux champs au moment de les exporter lorsque je les sélectionne tous, Longueur et RefLaq sont tous identique par rapport au premier enregistrement (voir capture) alors que ce n'est pas censé être du tout le cas.
Alors que si je fais un par un cela fonctionne correctement et je n'ai pas de problème sur ces deux champs.

J'ai comme l'impression que lorsque je sélectionne tous les enregistrement et que j'exporte, il ne découpe les champs que sur le premier et applique ces même valeurs à tous les enregistrements
Pièce jointe 628574
Je pense que je peux résumé le problème comme cela --> La requête Update s'effectue une fois pour le premier enregistrement puis copie avec les suivants du fait que la valeur sois toujours dans la variable

J'espère que vous avez compris mon problème sinon j'apporterai plus de précision.

Cdlt

08/11/2022, 15h09
Kyndred40

J'aurais penser à essayer de faire une boucle et a chaque fois qu'on a finit cette boucle pour un enregistrement par exemple les variables se remettent à 0 et le code se relance mais sur l'enregistrement suivant.
Depuis tout à l'heure j'essai plein de chose en vain je n'y arrive pas pour le moment
08/11/2022, 16h20
Robert1957
Bonjour william.rodde,

Il n'y a pas d'erreur dans le fonctionnement. Explication:

Code:

Set rst = dbs.OpenRecordset(strSql, dbOpenDynaset)

Ici vous ouvrez un "RecordSet" qui contient le nombre de lignes que vous avez cochées. Par défaut le curseur va au premier enregistrement du jeu d'enregistrement.

Code:

extraitD = Right(rst.Fields("NumArticle"), 6)

Ici vous affectez une valeur à la variable extraitD qui provient de ce premier enregistrement.
Code:

1 2 CurrentDb.Execute "UPDATE Commande " & _ "SET Commande.Laquage = '" & RefLaq & "' Where Selection=True ;"
Ici vous mettez à jour tous les enregistrements qui sont cochés avec la même valeur. C'est la raison pour laquelle toutes les lignes ont le même résultat.

Pour faire ce que vous désirez il faudrait faire ceci :

Code:

UPDATE Commande SET Commande.Laquage = Right([NumArticle],6) Where Selection=True;

Il n'est pas nécessaire d'ouvrir un "RecordSet" mais bien d'exécuter ce genre de requête. Toutes les lignes avec "Selection=True" seront impactées avec la valeur qui correspond à leurs lignes. À adapter a votre Bd.

Bonne journée

Salut
A tester, mais sans garantie du tout avec cette UAG

Code:

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
Private Sub Exporter_Click()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset, rst1 As DAO.Recordset, rst2 As DAO.Recordset
Dim strSql As String
 
Set dbs = CurrentDb
 
strSql = "SELECT * FROM Commande WHERE Selection = True "
Set rst = dbs.OpenRecordset(strSql, dbOpenDynaset)
 
'test = DLookup("[PoidsTH]", "base", "[Référence] = '" & extraitG & "' ")
strSql = "SELECT * FROM base WHERE [Référence] = '" & Left(rst.Fields("NumArticle"), InStr(rst.Fields("NumArticle"), Right(rst.Fields("NumArticle"), 6)) - 1) & "'"
Set rst1 = dbs.OpenRecordset(strSql, dbOpenDynaset)
'test = rst1.Fields("PoidsTH")
 
'Filière = DLookup("[Filiere]", "Feuil2", "[Référence] = '" & extraitG & "' ")
strSql = "SELECT * FROM Feuil2 WHERE [Référence] = '" & Left(rst.Fields("NumArticle"), InStr(rst.Fields("NumArticle"), Right(rst.Fields("NumArticle"), 6)) - 1) & "'"
Set rst2 = dbs.OpenRecordset(strSql, dbOpenDynaset)
'filière = rst2.Fields("Filiere")
 
dbs.Execute "UPDATE Commande SET Laquage = '" & Left(Right(rst.Fields("NumArticle"), 6), 2) & "'" _
& " SET PoidsTH = '" & rst1.Fields("PoidsTH") & "'" _
& " SET Ref = '" & Left(rst.Fields("NumArticle"), InStr(rst.Fields("NumArticle"), Right(rst.Fields("NumArticle"), 6)) - 1) & "'" _
& " SET Longueur = '" & Right(rst.Fields("NumArticle"), 4) & "'" _
& " SET NumFiliere = '" & rst2.Fields("Filiere") & "'" _
& " WHERE Selection = True", dbFailOnError
 
dbs.Execute "INSERT INTO EnAttPlanification(NumOrigine, Numero, NumArticle, CodeVariante, DateCommande, DateLivDemander, QteManquante, QteRestante, QtePretDepart, PoidsManquant, Observations, NomDestinataire, NumDestination, Qte, Longueur, Ref, PoidsTH, Laquage, NumFiliere)" _
        & " SELECT  NumOrigine, Numero, NumArticle, CodeVariante, DateCommande, DateLivDemander, QteManquante, QteRestante, QtePretDepart, PoidsManquant, Observations, NomDestinataire, NumDestination, Qte, Longueur, Ref, PoidsTH, Laquage, NumFiliere" _
        & " FROM Commande" _
        & " WHERE Selection = True", dbFailOnError
 
dbs.Execute " DELETE * FROM Commande WHERE Selection = True", dbFailOnError
 
Me.Requery
Me.Refresh
 
rst2.Close
rst1.Close
rst.Clone
dbs.Close
Set rst2 = Nothing
Set rst1 = Nothing
Set rst = Nothing
Set dbs = Nothing
End Sub

09/11/2022, 09h49
Kyndred40

1 pièce(s) jointe(s)

Salut Hyperion
Merci pour le code ! Seulement j'ai une erreur lors de l'exécution du code:
Pièce jointe 628631
Est ce que ce n'est pas une histoire d'apostrophe ou quoi car la syntaxe me parait bien .

Cdlt
09/11/2022, 11h40
micniv

si tu veux faire un UPDATE sur plusieurs colonnes, revoie ta syntaxe : un seul SET puis des , entre les différentes colonnes à mettre à jour
09/11/2022, 11h44
Kyndred40

Bonjour,

D'accord je vais essayer de voir comment je peux faire ça merci

re
Mon erreur est tellement énorme que je suis passé à côté hier soir :ptdr:
J'ai oublié les virgules entre L21/L24 et j'ai ajouté une palanquée de SET :ptdr:
Remplacez L21/L26 par

Code:

1
2
3
4
5
6
7
dbs.Execute "UPDATE Commande" _
& " SET Laquage = '" & Left(Right(rst.Fields("NumArticle"), 6), 2) & "'," _
& " PoidsTH = '" & rst1.Fields("PoidsTH") & "'," _
& " Ref = '" & Left(rst.Fields("NumArticle"), InStr(rst.Fields("NumArticle"), Right(rst.Fields("NumArticle"), 6)) - 1) & "'," _
& " Longueur = '" & Right(rst.Fields("NumArticle"), 4) & "'," _
& " NumFiliere = '" & rst2.Fields("Filiere") & "'" _
& " WHERE Selection = True", dbFailOnError

09/11/2022, 13h34
Kyndred40

Re,

Merci hyperion en effet ce code la fonctionne merci !
Comme vous m'aviez dis ce n'était pas garantie que cela fonctionne en effet cela à le même comportement qu'avant c'est à dire que le champ Laquage et Ref sont identique pour toutes les commandes qui sont coché.

Je me demande est-ce si on rajoute une condition cela réagirai comme je le souhaite ? fin du moins j'ai déjà essayer avec Id=Id mais rien ne change.

Auriez vous une idée de comment faire et si cela est possible ?

re
possible d'avoir un extrait de bdd avec uniquement les tbl et form concernées par le problème?
et d'exporter avec le code ci-dessous les tbl au format xml, si jamais je me retrouve à ne pas pouvoir ouvrir lesdites tbl comme la dernière !
Code:

1 2 3 4 5 6 Private Sub btnExportTableXml_Click() Application.ExportXML acExportTable, "Commande", "C:\Users\...\Commande.xml" Application.ExportXML acExportTable, "base", "C:\Users\...\base.xml" Application.ExportXML acExportTable, "Feuil2", "C:\Users\...\Feuil2.xml" Application.ExportXML acExportTable, "EnAttPlanification", "C:\Users\...\EnAttPlanification.xml" End Sub

09/11/2022, 13h45
Kyndred40

Oui je vais faire cela je vais faire une version avec que les tables et formulaire concerné
09/11/2022, 14h05
Kyndred40

5 pièce(s) jointe(s)

Je n'ai laisser que les formulaire nécessaire normalement il n'y en a pas d'inutile j'ai juste laisser ce qu'il fallait j'espère que vous allez pouvoir l'ouvrir
Pièce jointe 628650
Pièce jointe 628651
Pièce jointe 628652
Pièce jointe 628653

Pièce jointe 628654

Si vous voulez faire des test je vous conseil de vous servir des 5 champs que j'ai déjà coché et qui sont toujours coché d'ailleurs (table commande) car je suis passé par un bouton nommé "Update" (il y en a qui ne fonctionne pas car il ne dois pas trouver de valeur par rapport a la Ref ) pour faire des essai plutôt que d'exporter vers l'autre table.
09/11/2022, 14h12
hyperion13

re,
Ok j'ai récupéré les fichiers
Nous sommes bien d'accord, tout démarre depuis le form Commande où tu coches Sélection pour traiter les différents UPDATE et le INSERT INTO dans EnAttPlanification.
09/11/2022, 14h14
Kyndred40

re,
En effet ces cela ce formulaire c'est la ou tout démarre. Oui je coche Selection et quand je clique vers Exporter cela les exporte et avant l'export fait un UPDATE pour obtenir des champs comme Laquage,Ref et NumFiliere
09/11/2022, 14h21
hyperion13

ok
réponse au plus tard demain matin aux aurores :mrgreen:
09/11/2022, 14h23
Kyndred40

D'accord pas de soucis prenez votre temps :D merci beaucoup par avance

2 pièce(s) jointe(s)

re
Mauvaise surprise avec ta bdd !
Tu travailles sur quelle version d'Acc ?
Je trouve étonnant d'avoir l'impossibilité parfois d'ouvrir des bdd ou certains de leurs objets (tbl/frm) de certains utilisateurs ici. :weird:
Pas certain que cela vienne de ma version PackOfficePro 2013 32bits, car à l'UR je bosse sur PackOffice 2019 32bits et je ne rencontre aucun problème lorsque je bosse chez moi !
Pour autant
en VBA
Je n'ai pas testé au-delà de L24. Je ne sais pas à quoi correspond le champ Ref.

Code:

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
Private Sub Exporter_Click()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strSql As String
 
Set dbs = CurrentDb
 
strSql = "SELECT * FROM Commande WHERE Selection = True "
Set rst = dbs.OpenRecordset(strSql, dbOpenDynaset)
 
If rst.RecordCount > 0 Then
    rst.MoveLast
    rst.MoveFirst
    Do Until rst.EOF
        rst.Edit
        rst.Fields("Longueur") = Right(rst.Fields("NumArticle"), 4)
        rst.Fields("PoidsTH") = Nz(DLookup("[PoidsTH]", "[base]", "[Référence] = '" & Left(rst.Fields("NumArticle"), InStr(rst.Fields("NumArticle"), Right(rst.Fields("NumArticle"), 6)) - 1) & "'"))
        rst.Fields("NumFiliere") = Nz(DLookup("[Filiere]", "[Feuil2]", "[Référence] = '" & Left(rst.Fields("NumArticle"), InStr(rst.Fields("NumArticle"), Right(rst.Fields("NumArticle"), 6)) - 1) & "'"))
        rst.Fields("Laquage") = Left(Right(rst.Fields("NumArticle"), 6), 2)
        rst.Update
        rst.MoveNext
    Loop
End If
 
dbs.Execute "INSERT INTO EnAttPlanification(NumOrigine, Numero, NumArticle, CodeVariante, DateCommande, DateLivDemander, QteManquante, QteRestante, QtePretDepart, PoidsManquant, Observations, NomDestinataire, NumDestination, Qte, Longueur, Ref, PoidsTH, Laquage, NumFiliere)" _
    & " SELECT  NumOrigine, Numero, NumArticle, CodeVariante, DateCommande, DateLivDemander, QteManquante, QteRestante, QtePretDepart, PoidsManquant, Observations, NomDestinataire, NumDestination, Qte, Longueur, Ref, PoidsTH, Laquage, NumFiliere" _
    & " FROM Commande" _
    & " WHERE Selection = True", dbFailOnError
 
dbs.Execute " DELETE * FROM Commande WHERE Selection = True", dbFailOnError
 
Me.Requery
Me.Refresh
 
rst.Clone
dbs.Close
Set rst = Nothing
Set dbs = Nothing
End Sub

En Sql

Code:

1
2
UPDATE Commande SET Longueur = Right([NumArticle],4), PoidsTH = DLookUp("[PoidsTH]","[base]","[Référence] = '" & Left([NumArticle],InStr([NumArticle],Right([NumArticle],6))-1) & "'"), Laquage = Left(Right([NumArticle],6),2), NumFiliere = DLookUp("[Filiere]","[Feuil2]","[Référence] = '" & Left([NumArticle],InStr([NumArticle],Right([NumArticle],6))-1) & "'")
WHERE Selection = True

10/11/2022, 09h52
Kyndred40

Re,
J'utilise il me semble Access 2019 enfin la dernière version je crois je regarderai sa de plus près Lundi.
Mais en effet cela doit être particulièrement chiant de ne pas pouvoir ouvrir les BDD de certains à cause de problème de version.
Le champ Ref correspond par exemple à CE13601 du champ (CE13601LA4740) pour faire simple le champ Ref est tout ce qui est à gauche du champ Laquage (2caractères --> LA, XX, ZZ ...)

En tout cas merci pour le code que je testerai dès que possible c'est à dire Lundi car moi non plus je ne peux pas accéder à ma BDD depuis mon Pc personnel à cause aussi d'un problème de version :ptdr:

re
Ok. Donc remplacer le bloc L11/L23 Post#17 par ce qui suit s'il faut calculer Ref

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
If rst.RecordCount > 0 Then
    rst.MoveLast
    rst.MoveFirst
    Do Until rst.EOF
        rst.Edit
        rst.Fields("Longueur") = Right(rst.Fields("NumArticle"), 4)
        rst.Fields("Ref") = Left(rst.Fields("NumArticle"), InStr(rst.Fields("NumArticle"), Right(rst.Fields("NumArticle"), 6)) - 1)
        rst.Fields("PoidsTH") = Nz(DLookup("[PoidsTH]", "[base]", "[Référence] = '" & Left(rst.Fields("NumArticle"), InStr(rst.Fields("NumArticle"), Right(rst.Fields("NumArticle"), 6)) - 1) & "'"))
        rst.Fields("NumFiliere") = Nz(DLookup("[Filiere]", "[Feuil2]", "[Référence] = '" & Left(rst.Fields("NumArticle"), InStr(rst.Fields("NumArticle"), Right(rst.Fields("NumArticle"), 6)) - 1) & "'"))
        rst.Fields("Laquage") = Left(Right(rst.Fields("NumArticle"), 6), 2)
        rst.Update
        rst.MoveNext
    Loop
End If

14/11/2022, 08h56
Kyndred40

Re

Parfait merci beaucoup le code fonctionne parfaitement comme je le souhaite, je vous remercie !

Cdlt