Demande d'aide de modification d'un fichier excel + VBA gérant une balance

**nirvana4483** · 11/07/2024, 09h47

j'ai du mal avec le fonctionnement de la macro Autoremplissage

hélas je ne comprends pas cette ligne majeure, avec ce multiple de 3

Code :

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

If feuille.Cells(j, colonne - (i * 3)) = "" Then

j'ai donc désactivé cette fonction Autoremplissage en attendant

je me dit qu'il faudrait remplir les cellules du template "de base" de l'info "pesée non faite" comme cela, la première pesée écraserait la cellule remplie, (mais cela reste de la bidouille non optimale.)

Le but c'est éviter qu'en début de vacation, les personnes passant après la 1ière personne pour peser se retrouvent avec "pesée non faite" dans la première colonne, et donc que leur pesée aille dans la cellule normalement prévue pour la fin de vacation "

Ne comprenant pas bien le code, je n'arrive pas à modifier le code pour le remplissage suite à la modification du template qui a donc des colonnes supplémentaires à présent

et concernant la mise en forme conditionnelle, j'ai trouvé !! La condition pour "NOK" doit être ajouter en premier pour s'assurer que les cellules contenant "NOK" sont colorées en rouge avant que la condition pour "OK" puisse les affecter.

**nirvana4483** · 17/07/2024, 12h22

Bonjour à vous, merci encore pour votre aide

=>J'abandonne pour l'instant l'idée avec la macro Autoremplissage, d'inscrire "pesée non faite" car je n'arrive pas à adapter le code et pas la 1ière priorité
=>j'ai réussi à solutionner mon souci de mise en forme conditionnelle

j'ai besoin de votre aide car la logique de remplissage de l'onglet IMS ne fonctionne pas correctement, peut-être dois-je ouvrir un nouveau post?

Si pesée OK, cela fonctionne Nom : ok.JPG
Affichages : 154
Taille : 5,2 Ko

Nom : ok.JPG
Affichages : 154
Taille : 5,2 Ko

Si mise à jour du poids, l'utilisateur clique sur "oui" pour modifier son poids de référence, cela fonctionne Nom : maj.JPG
Affichages : 200
Taille : 5,4 Ko

mais si l'utilisateur ne mets pas à jour son poids suite à détection d'une erreur, en cliquant sur NON,

Nom : fenetre.JPG
Affichages : 148
Taille : 52,2 Ko

cela affiche toujours Nom : maj.JPG
Affichages : 200
Taille : 5,4 Ko

au lieu d'afficher NOK Nom : nok.JPG
Affichages : 143
Taille : 4,0 Ko

ancien 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
Sub rempl_IMS(arg) 'Remplissage automatique de l'onglet IMS de la semaine en cours + mise en forme conditionnelle des cellules
 
Application.ScreenUpdating = False
 
Set rech_nom = Nothing
Set rech_nom = Sheets("IMS_CW" & num_sem & "_" & annee).Range("A:A").Find(what:=nom_toolmoov & " " & pre_toolmoov, lookat:=xlWhole, MatchCase:=False)
Set rech_date = Nothing
Set rech_date = Sheets("IMS_CW" & num_sem & "_" & annee).Range("13:13").Find(what:=aujourdhui, lookat:=xlWhole, MatchCase:=False)
 
If arg <> "" Then
    Sheets("IMS_CW" & num_sem & "_" & annee).Unprotect ("admin")
    If Worksheets("IMS_CW" & num_sem & "_" & annee).Cells(rech_nom.Row, rech_date.Column) <> "MAJ" Then
        Worksheets("IMS_CW" & num_sem & "_" & annee).Cells(rech_nom.Row, rech_date.Column) = arg
        Worksheets("IMS_CW" & num_sem & "_" & annee).Cells(rech_nom.Row, rech_date.Column + 1) = ecart & " en Kg "
    End If
 
    If arg = "MAJ" Then Worksheets("IMS_CW" & num_sem & "_" & annee).Cells(rech_nom.Row, rech_date.Column + 1) = ecart & " en Kg " & vbLf & commentaire
End If
Autoremplissage rech_date.Column, Worksheets("IMS_CW" & num_sem & "_" & annee)
 
Sheets("IMS_CW" & num_sem & "_" & annee).Protect Password:="admin", DrawingObjects:=True, Contents:=True, Scenarios:=True
ThisWorkbook.Save
 
Application.ScreenUpdating = True
 
End Sub

nouveau code actuel, suite à la modification du template pour avoir une remontée des 2 pesée, début et fin de vac

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
Sub rempl_IMS(arg) 'Remplissage automatique de l'onglet IMS de la semaine en cours + mise en forme conditionnelle des cellules
    Dim kR As Long, kC As Integer
    Application.ScreenUpdating = False
    With Worksheets("IMS_CW" & num_sem & "_" & annee)
       If arg <> "" Then
            Set rech_nom = Nothing
            Set rech_nom = .Range("A:A").Find(what:=nom_toolmoov & " " & pre_toolmoov, lookat:=xlWhole, MatchCase:=False)
            kR = rech_nom.Row
            Set rech_date = Nothing
            Set rech_date = .Range("13:13").Find(what:=aujourdhui, lookat:=xlWhole, MatchCase:=False)
            kC = rech_date.Column
            .Unprotect "admin"
            If .Cells(kR, kC) <> "" Then
                If .Cells(kR, kC + 3) <> "" Then           'les deux champs remplis on recommence
                   .Cells(kR, kC).Resize(1, 5) = ""  'on efface les 5 colonnes successives
                Else
                   kC = kC + 3
                End If
            End If
 
            If .Cells(kR, kC) <> "MAJ" Then
               '.Cells(kR, kC) = arg
               '.Cells(kR, kC) = arg & vbLf & Format(Time, "hh:mm")
               .Cells(kR, kC) = arg & vbLf & Format(Now, "dd/mm/yy hh\hnn")
            End If
            If arg = "MAJ" Then
                .Cells(kR, kC + 1) = ecart & " Kg " & vbLf & commentaire
            Else
                .Cells(kR, kC + 1) = ecart & " Kg"
            End If
        End If
        Autoremplissage kC, Worksheets("IMS_CW" & num_sem & "_" & annee)
        .Protect Password:="admin", DrawingObjects:=True, Contents:=True, Scenarios:=True
    End With
 
    ThisWorkbook.Save
    Application.ScreenUpdating = True
End Sub

Invité · 17/07/2024, 14h36

j'ai besoin de votre aide car la logique de remplissage de l'onglet IMS ne fonctionne pas correctement, peut-être dois-je ouvrir un nouveau post?

Est-ce que le code fonctionnait dans l'ancienne version car cette condition interdit toute modification une fois la cellule passe à "MAJ"
Ancien

Code :

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

If Worksheets("IMS_CW" & num_sem & "_" & annee).Cells(rech_nom.Row, rech_date.Column) <> "MAJ" Then

ou nouveau

Code :

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

If .Cells(kR, kC) <> "MAJ" Then

Malgré que ce dernier est incorrect toujours Vrai parce que la cellule contient MAJ + Date ce dernier doit etre réécrit comme suit : ce code a été déjà posté il fallut être un peu attentif

Code :

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

If InStr(.Cells(kR, kC), "MAJ") = 0 Then

Mais je pense que l'erreur n'est pas là, NOK n'est présent qu'une seule fois dans le code lorsque le badge est vide j'imagine que cette variable continent une ancienne saisie qui n'a pas été réinitialisée

Dans le fonction comparaison vider cette variable ..

Code :

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

1
2
Sub comparaison()
badge = ""

**nirvana4483** · 17/07/2024, 14h59

Envoyé par Volid

Est-ce que le code fonctionnait dans l'ancien version car cette condition interdit toute modification une fois la cellule passe à "MAJ"

Cela devait probablement dysfonctionner dans l'ancien fichier, je peux aller le vérifier, l'onglet IMS nous servait pas avant

Envoyé par Volid

Malgré que ce dernier est incorrect toujours Vrai parce que la cellule contient MAJ + Date ce dernier doit être réécrit comme suit : ce code a été déjà posté il fallut être un peu attentif

Code :

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

If InStr(.Cells(kR, kC), "MAJ") = 0 Then

Je n'ai pas cette ligne car elle était dans le code que tu avais écris pour la prise en compte des vacations, je l'ai actuellement pas utilisé car on fait trop d'horaires différents.
Mais il servira probablement plus tard

je me suis peut-être emmêlé les pinceaux, car je ne comprends pas l'intégralité des subtilités du code.. et oui je reste un bidouilleur et non un développeur au sens noble du terme. Et je manque cruellement de temps pour me perfectionner

Envoyé par Volid

Mais je pense que l'erreur n'est pas là, NOK n'est présent qu'une seule fois dans le code lorsque le badge est vide j'imagine que cette variable continent une ancienne saisie qui n'a pas été réinitialisée

Dans le fonction comparaison vider cette variable ..

Code :

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

1
2
Sub comparaison()
badge = ""

oui j'avais repéré cela, effectivement le code semble pas appelé NOK, le badge c'est que l'opérateur doit zipper son code barre pour modifier son poids de référence

pour le coup il serait plus simple que si l'opérateur clique sur NON et ne termine pas son process de pesée, qu'on a aucune info qui s'inscrit dans l'onglet IMS, comme cela on a que les pesées OK et les vrai MAJ quand ils cliquent sur oui

Nom : fenetre.JPG
Affichages : 145
Taille : 52,2 Ko

Nom : fenetre.JPG
Affichages : 145
Taille : 52,2 Ko

**nirvana4483** · 17/07/2024, 15h43

Envoyé par nirvana4483

pour le coup il serait plus simple que si l'opérateur clique sur NON et ne termine pas son process de pesée, qu'on a aucune info qui s'inscrit dans l'onglet IMS, comme cela on a que les pesées OK et les vrai MAJ quand ils cliquent sur oui

très clairement, je ne sais pas le faire sans mettre des heures voir des jours, voir des années

pesée ok => Nom : ok.JPG
Affichages : 149
Taille : 5,2 Ko

cela fonctionne
mise à jour du poids => Nom : maj.JPG
Affichages : 143
Taille : 5,4 Ko

cela fonctionne
pesée abandonné en cliquant sur non, par exemple pour aller vérifier sa caisse=> on ne remplit rien, on laisse la cellule vide... cela fonctionne pas

Invité · 17/07/2024, 18h21

Voila la partie du code dans la fonction comparaison qui affiche le dialogue

Code :

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

1
2
3
4
5
6
7
8
9
10
    If Abs(ecart) > 0.0015 Then 'modif magré 02/04/24 de 0.0008 à 0.0015
        If MsgBox("Poids de la caisse n° " & numero_caisse & " différent du poids de référence de : " & (ecart * 1000) & "grammes" & vbCr & vbCr & "Voulez-vous modifier ce poids de référence?" & vbCr & vbCr & "Attention vous certifiez que votre caisse est conforme à la politique FOD SAFRAN", vbYesNo + vbDefaultButton2) = vbYes Then
            'modification du Referentiel_poids_caisse
            valider_pesée
            ecrit_log
        Else  
            'vérification avant nouvelle pesée
            MsgBox "Vérifiez votre caisse!!!"
            ecrit_log
        End If

dans la première section de bloc If la partie exécutée si OUI est saisie

Code :

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

1
2
3
            'modification du Referentiel_poids_caisse
            valider_pesée
            ecrit_log

La seconde partie est celle du NON .. donc il suffit juste de la supprimer ou désactiver pour annuler toute écriture dans l'onglet IMS si le bouton non est cliqué

Code :

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

1
2
3
            'vérification avant nouvelle pesée
            MsgBox "Vérifiez votre caisse!!!"
            ecrit_log

**nirvana4483** · 17/07/2024, 19h16

Merci, J'irais testé demain matin 👍

**nirvana4483** · 18/07/2024, 12h12

Merci pour le support

C'est mis en place!
J'ai modifié comme ci dessous pour ne plus afficher le NOK, j'ai ainsi la traçabilité du NOK dans les LOG
j'attends de voir si tout fonctionne correctement

dans Sub comparaison()

Code :

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

1
2
3
'vérification avant nouvelle pesée
            MsgBox "Vérifiez votre caisse!!!"
            ecrit_log3

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
Sub ecrit_log3()
 
    unprot
 
 log = "LOG"
    der_lig Sheets(log), "A1"
    With Sheets(log)
    .Range("A" & dern_ligne + 1) = Date
    .Range("B" & dern_ligne + 1) = Time
    .Range("C" & dern_ligne + 1) = numero_caisse
    .Range("D" & dern_ligne + 1) = nom_toolmoov & " " & pre_toolmoov
    .Range("E" & dern_ligne + 1) = ecart
    .Range("F" & dern_ligne + 1) = poidref
    .Range("G" & dern_ligne + 1) = valeurmef
    .Range("H" & dern_ligne + 1) = badge
    .Range("I" & dern_ligne + 1) = nom
    '.Range("J" & dern_ligne + 1) = nomsup
    .Range("K" & dern_ligne + 1) = commentaire
    End With
 
'If badge = "" Then
'rempl_IMS "NOK"
'noircir 'remplissage automatique absence S/D pour les pers de jour et M/M/J pour les pers de VSD pas le lundi si rattapage
 
'Else
'rempl_IMS "MAJ"
'noircir 'remplissage automatique absence S/D pour les pers de jour et M/M/J pour les pers de VSD pas le lundi si rattapage
'End If
 
    prot
 
End Sub

**nirvana4483** · 22/07/2024, 11h20

Bonjour à vous,
j'ai encore besoin de votre aide, pour une amélioration.

j'ai rajouté un filtre dans le template IMS sur le nom et j'aimerais aussi pouvoir filtrer par vacation (horaire 3*8): team 1, team 2, team 3

j'ai donc besoin de rajouter l'information team1, team2, team3 quelques part, c'est pour pouvoir vérifier rapidement qui n'a pas effectué sa pesée

j'ai rajouté l'information de la team dans l'onglet BDD_Safran colonne D> "T1", "T2", "T3"
Nom : bdd.JPG
Affichages : 117
Taille : 23,6 Ko

Nom : bdd.JPG
Affichages : 117
Taille : 23,6 Ko

j'ai en conséquence modifié le code ainsi dans la macro Sub creat_IMS() en rouge

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
    With Sheets(IMS)
    .Range("A" & dern_ligne_IMS) = Sheets(bdd_saf).Range("D" & i) & "-" & Sheets(bdd_saf).Range("A" & i) & " " & Sheets(bdd_saf).Range("B" & i)
    .Cells(dern_ligne_IMS, 1).Select
    End With
    
    For j = 1 To 7
    col = (j * 3) + 1
    
    With Sheets(IMS)
    .Range("A" & dern_ligne_IMS) = Sheets(bdd_saf).Range("D" & i) & "-" & Sheets(bdd_saf).Range("A" & i) & " " & Sheets(bdd_saf).Range("B" & i)
    .Cells(dern_ligne_IMS, col).Select
    End With

cela donne donc ceci
Nom : T1.JPG
Affichages : 121
Taille : 12,4 Ko

c'était parfait pour filtrer, soit par nom ou team T1, T2 ou T3

sauf que le code n'aime pas cela

et bloque à kR = rech_nom.Row dans la macro Sub rempl_IMS (arg)

Nom : kr.JPG
Affichages : 117
Taille : 69,7 Ko

Comment remédier à cela, Je n'ai pas voulu ajouté une nouvelle colonne team à coté de la colonne Name dans l'onglet IMS, car cela risquerait de décaler tous le code

Nom : T1-.JPG
Affichages : 116
Taille : 18,7 Ko

Nom : T1-.JPG
Affichages : 116
Taille : 18,7 Ko

Et en regardant rech_nom.Row, je me dit que mon essai de modif risque d'impacter ailleurs et faire buguer d'autre macro

Invité · 22/07/2024, 19h57

Comment remédier à cela, Je n'ai pas voulu ajouté une nouvelle colonne team à coté de la colonne Name dans l'onglet IMS, car cela risquerait de décaler tous le code

La fonction Find exclue de la recherche les cellules invisibles / cachées par le filtre pour effectuer la recherche correctement soit par la désactivation du filtre ou utilisation de la fonction Match:
remplacer cette partie

Code :

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

1
2
  Set rech_nom = .Range("A:A").Find(what:=nom_toolmoov & " " & pre_toolmoov, lookat:=xlWhole, MatchCase:=False)
            kR = rech_nom.Row

Par :

Code :

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

 kR = Application.WorksheetFunction.Match(nom_toolmoov & " " & pre_toolmoov, .Range("A:A"), 0)

Pour en revenir à la mise en forme des cellules selon son status "OK", "NOK" ou "MAJ" on peut le déterminer lors de la mise à jour de la cellule en sélectionnant l'indice de la couleur en fonction de la valeur de arg :

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
            If .Cells(kR, kC) <> "" Then
                If .Cells(kR, kC + 3) <> "" Then           'les deux champs remplis on recommence
                   .Cells(kR, kC).Resize(1, 5) = ""  'on efface les 5 colonnes successives
                   .Cells(kR, kC).Resize(1, 5).Interior.ColorIndex = xlColorIndexNone
                Else
                   kC = kC + 3
                End If
            End If
 
            If .Cells(kR, kC) <> "MAJ" Then
               '.Cells(kR, kC) = arg
               '.Cells(kR, kC) = arg & vbLf & Format(Time, "hh:mm")
               .Cells(kR, kC) = arg & vbLf & Format(Now, "dd/mm/yy hh\hnn")
 
               Select Case arg
                  Case "OK": .Cells(kR, kC).Interior.ColorIndex = 4
                  Case "NOK": .Cells(kR, kC).Interior.ColorIndex = 3
                  Case "MAJ": .Cells(kR, kC).Interior.ColorIndex = 45
                  Case Else: .Cells(kR, kC).Interior.ColorIndex = xlColorIndexNone
               End Select
 
            End If

J’espère que cela fonctionne .

Invité · 22/07/2024, 20h12

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
Sub ecrit_log3()
 
    unprot
 
 log = "LOG"
    der_lig Sheets(log), "A1"
    With Sheets(log)
    .Range("A" & dern_ligne + 1) = Date
    .Range("B" & dern_ligne + 1) = Time
    .Range("C" & dern_ligne + 1) = numero_caisse
    .Range("D" & dern_ligne + 1) = nom_toolmoov & " " & pre_toolmoov
    .Range("E" & dern_ligne + 1) = ecart
    .Range("F" & dern_ligne + 1) = poidref
    .Range("G" & dern_ligne + 1) = valeurmef
    .Range("H" & dern_ligne + 1) = badge
    .Range("I" & dern_ligne + 1) = nom
    '.Range("J" & dern_ligne + 1) = nomsup
    .Range("K" & dern_ligne + 1) = commentaire
    End With
 
'If badge = "" Then
'rempl_IMS "NOK"
'noircir 'remplissage automatique absence S/D pour les pers de jour et M/M/J pour les pers de VSD pas le lundi si rattapage
 
'Else
'rempl_IMS "MAJ"
'noircir 'remplissage automatique absence S/D pour les pers de jour et M/M/J pour les pers de VSD pas le lundi si rattapage
'End If
 
    prot
 
End Sub

Tu n'es pas obligé à céer une nouvelle fonction compliquant davantage le code et surtout la lisibilité,

Ajouter un paramètre pour ecrit_log qui permet d'activer ou désactiver l’écriture dans l'onglet IMS

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
 
Sub ecrit_log(Optional ByVal EcrireIMS = True) 'écriture dans l'onglet "LOG"
 
 unprot
 
 log = "LOG"
    der_lig Sheets(log), "A1"
    With Sheets(log)
    .Range("A" & dern_ligne + 1) = Date
    .Range("B" & dern_ligne + 1) = Time
    .Range("C" & dern_ligne + 1) = numero_caisse
    .Range("D" & dern_ligne + 1) = nom_toolmoov & " " & pre_toolmoov
    .Range("E" & dern_ligne + 1) = ecart
    .Range("F" & dern_ligne + 1) = poidref
    .Range("G" & dern_ligne + 1) = valeurmef
    .Range("H" & dern_ligne + 1) = badge
    .Range("I" & dern_ligne + 1) = nom
    '.Range("J" & dern_ligne + 1) = nomsup
    .Range("K" & dern_ligne + 1) = commentaire
    End With
If EcrireIMS Then
    If badge = "" Then
    rempl_IMS "NOK"
    'noircir 'remplissage automatique absence S/D pour les pers de jour et M/M/J pour les pers de VSD pas le lundi si rattapage
 
    Else
    rempl_IMS "MAJ"
    'noircir 'remplissage automatique absence S/D pour les pers de jour et M/M/J pour les pers de VSD pas le lundi si rattapage
    End If
End If
prot
 
End Sub

pour l'utiliser
ecrit_log False

**nirvana4483** · 23/07/2024, 11h24

Merci je suis allé tester cela
j'ai laissé mon code modifié ainsi dans la macro Sub creat_IMS() en rouge

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
    With Sheets(IMS)
    .Range("A" & dern_ligne_IMS) = Sheets(bdd_saf).Range("D" & i) & "-" & Sheets(bdd_saf).Range("A" & i) & " " & Sheets(bdd_saf).Range("B" & i)
    .Cells(dern_ligne_IMS, 1).Select
    End With
    
    For j = 1 To 7
    col = (j * 3) + 1
    
    With Sheets(IMS)
    .Range("A" & dern_ligne_IMS) = Sheets(bdd_saf).Range("D" & i) & "-" & Sheets(bdd_saf).Range("A" & i) & " " & Sheets(bdd_saf).Range("B" & i)
    .Cells(dern_ligne_IMS, col).Select
    End With

et j'ai remplacé la ligne par la tienne , dans la macro rempl_IMS(arg)

Code :

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

 kR = Application.WorksheetFunction.Match(nom_toolmoov & " " & pre_toolmoov, .Range("A:A"), 0)

Cela ne fonctionne pas

Mais j'ai eu une lueur dans la nuit! j'ai renseigné directement la team dans le nom de l'opérateur, exemple: T1-Dupont, cela fonctionne ainsi

. Certes moins professionnel et dev pur

Ainsi, je pense que l'on peut s'épargner de s'arracher les cheveux, cela me va comme çà.

Par contre merci pour la modification avec écrire IMS, c'est clairement le truc que je comprends oui fois écrit, mais je n'ai pas les connaissances/compétences pour savoir l'écrire moi-même

**nirvana4483** · 20/08/2024, 12h20

Bonjour à tous, j'espère que vous allez bien
Retour de vacances pour moi et 1er bugue qui déprime

J'arrive à mes fins, j'espère cela sera la dernière modification.
Mais j'ai encore besoin de vos compétences

j'ai voulu modifié le code original qui tous les lundis matin, au changement de semaine, sauvegarde l'onglet exemple "IMS_CW34_2024" et créé un nouveau template pour la nouvelle semaine en cours.

Voici l'ancien code d'archivage

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
'Sub archivage()
For Each feuille In Worksheets
    If Left(feuille.name, 3) = "IMS" Then
       Autoremplissage 23, feuille
        Source = ThisWorkbook.Path & "\Archive_IMS" 'Emplacement dynamique ou sont stocker les fichiers archivés lié à l'emplacement du log_balance
        If Dir(Source, vbDirectory) = "" Then MkDir Source 'Création automatique du répertoire
        Set wk = Workbooks.Add(xlWBATWorksheet)
        Set ws = feuille
        ws.Copy after:=wk.Sheets(Sheets.Count)
        With ActiveWorkbook
            .ActiveSheet.SaveAs fileName:=Source & "\" & feuille.name
            Application.DisplayAlerts = False
            .Sheets(1).Delete
            Application.DisplayAlerts = True
            .Save
            .Close
        End With
 
        Application.DisplayAlerts = False
        feuille.Delete
        Application.DisplayAlerts = True
    End If
Next feuille
 
End Sub

le code modifié que j'ai créé avec l'aide de google et un peu IA (il faut savoir utiliser les nouveaux outils

)..

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
 
Sub archivage()
    Dim feuille As Worksheet
    Dim Source As String
    Dim SecondSource As String
    Dim wk As Workbook
    Dim ws As Worksheet
 
    For Each feuille In Worksheets
        If Left(feuille.name, 3) = "IMS" Then
            Autoremplissage 23, feuille
            Source = ThisWorkbook.Path & "\Archive_IMS" ' Emplacement dynamique où sont stockés les fichiers archivés lié à l'emplacement du log_balance
            SecondSource = "E:\Archive_IMS" ' Emplacement fixe sur E:\
 
            ' Création automatique du répertoire dynamique s'il n'existe pas
            If Dir(Source, vbDirectory) = "" Then MkDir Source
            ' Création automatique du répertoire fixe s'il n'existe pas
            If Dir(SecondSource, vbDirectory) = "" Then MkDir SecondSource
 
            Set wk = Workbooks.Add(xlWBATWorksheet)
            Set ws = feuille
            ws.Copy after:=wk.Sheets(Sheets.Count)
 
            ' Sauvegarde dans le répertoire dynamique
            With ActiveWorkbook
                .ActiveSheet.SaveAs fileName:=Source & "\" & feuille.name
                Application.DisplayAlerts = False
                .Sheets(1).Delete
                Application.DisplayAlerts = True
                .Save
            End With
 
            ' Sauvegarde dans le répertoire fixe
            With ActiveWorkbook
                .ActiveSheet.SaveAs fileName:=SecondSource & "\" & feuille.name
                Application.DisplayAlerts = False
                .Sheets(1).Delete
                Application.DisplayAlerts = True
                .Save
                .Close
            End With
 
            ' Suppression de la feuille originale
            Application.DisplayAlerts = False
            feuille.Delete
            Application.DisplayAlerts = True
        End If
    Next feuille
 
End Sub

Mais la macro bloque ici, je ne comprends pas trop pourquoi
Nom : bug archivage IMS.JPG
Affichages : 96
Taille : 130,7 Ko

mon souhait avoir une sauvegarde dans le dossier Archive_IMS présent sur le bureau et un second sur la clé USB en redondance en cas de mort du disque dur.

voici le dernier fichier
balance connectée-save-26-07-24--.xlsm

**EricDgn** · 21/08/2024, 18h14

Bonjour,

Essayer ceci pour la partie Sauvegarde:

Code :

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

1
2
3
4
5
6
7
8
9
10
            ' Sauvegarde
            With ActiveWorkbook
                .ActiveSheet.SaveAs fileName:=Source & "\" & feuille.name           ' dans le répertoire dynamique
                .ActiveSheet.SaveAs fileName:=SecondSource & "\" & feuille.name     ' dans le répertoire fixe
                Application.DisplayAlerts = False
                .Sheets(1).Delete
                Application.DisplayAlerts = True
                .Save
                .Close
            End With

Cordialement.

**nirvana4483** · 23/08/2024, 10h11

Envoyé par EricDgn

Bonjour,

Essayer ceci pour la partie Sauvegarde:

Code :

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

1
2
3
4
5
6
7
8
9
10
            ' Sauvegarde
            With ActiveWorkbook
                .ActiveSheet.SaveAs fileName:=Source & "\" & feuille.name           ' dans le répertoire dynamique
                .ActiveSheet.SaveAs fileName:=SecondSource & "\" & feuille.name     ' dans le répertoire fixe
                Application.DisplayAlerts = False
                .Sheets(1).Delete
                Application.DisplayAlerts = True
                .Save
                .Close
            End With

Cordialement.

je vers tester cela merci

**nirvana4483** · 26/08/2024, 15h29

Merci cela semble fonctionner, verdict lundi 02/09/24

**nirvana4483** · 12/09/2024, 10h38

cela fonctionne merci

**nirvana4483** · 26/09/2024, 10h31

Bonjour à vous, j'ai détecté un bug par hasard

j'avais rajouté un filtre dans l'onglet IMS_CW35_2024, cela est une aide pour filtrer/vérifier les personnes ayant réaliser leur pesée.

Hélas si quelqu'un laisse filtré l'onglet IMS, cela fait planté le remplissage de cet l'onglet à la prochaine pesée. cela plante le code qui ne trouve pas le nom de la personne, à part si par chance le filtre laisse son nom.

j'ai tenté de supprimer et refaire le filtre dans la macro, en vain

ci-joint le fichier
Nom : souci filtre.JPG
Affichages : 51
Taille : 55,6 Ko

Nom : souci filtre.JPG
Affichages : 51
Taille : 55,6 Ko

il faudrait supprimer le filtre le refaire avant de remplir l'onglet IMS
balance connectée-save-26-08-24.xlsm mdp admin

Si quelqu'un d'entre vous peut regarder

je pense cela sera vraiment mon dernier souci afin de clôturer

**nirvana4483** · 30/09/2024, 12h40

je pense il faut retirer le filtre et le remettre dans cette macro =>rempl_IMS(arg) je dois mal m'y prendre

**rMist2024** · 01/10/2024, 22h58

Pour désactiver le filtre sélectionner la ligne ou les entêtes sont placé et après exécuter ce macro
Pour connaitre la dernière colonne non vide regarder dans le lien en bas

Code :

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

Range("A3:A9").AutoFilter

Pour réactiver le filtre sélectionner du plage qui subira le filtrage
Pour connaitre la zone de donnée valide dans une feuille regarder le lien

Code :

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

Range("$A$3:$C$9").AutoFilter Field:=1, Criteria1:="*"

https://www.developpez.net/forums/d2...age-se-decale/

Demande d'aide de modification d'un fichier excel + VBA gérant une balance

Macros et VBA Excel

Discussions similaires

Partager

Partager