VBA - Création de fiche individuelle + impression automatisée

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
C

cissou69

XLDnaute Junior
Bonjour,

Le but de cette macro est d'établir les fiches individuelles de tout un département contenant plusieurs personnes pour les imprimer en un seul clic via un userform pour choisir le département en question...
L'année dernière, ça nous a pris trois heures, le temps de sélectionner chaque personne, d'éditer la fiche et de l'imprimer !!

J'ai compilé plusieurs macros ensemble pour réaliser ces différentes taches avec des boucles entrelacées.
Mais quand je lance la macro, je plante Excel 😡
Etant plus que débutant, je viens demander votre aide.

Merci d'avance,

PS la gestion de Dpt.Value et de Inventorier.Value est réalisé dans le UserForm_Initialize

Code: 
Private Sub OK_Click()
    Unload Me
 
    a = 1
    i = 3
      
Do While a <> "Expositions"
    a = Worksheets(Dpt.Value).Cells(9, i).Value
    i = i + 1
        
    For i = 3 To 5  '5 valeur fictive a modifier
    Worksheets(Dpt.Value).Cells(9, i).Value = "unique"
            
        For j = 1 To 500
            While "unique" <> Worksheets("Personne").Cells(j, 1).Value
                j_memoire = j
                Nom_entier = Worksheets("Personne").Cells(j, 2).Value + "" + Worksheets("Personne").Cells(j, 3).Value
                Poste = Worksheets("Personne").Cells(i, 8).Value
            Wend
        Next

'Macro adaptee pour la creation de la fiche individuelle
        
        Cells(2, 1).Value = "Inventorier par : " + Inventorier.Value
        Cells(3, 1).Value = "Personne concernée : " + Status
        Cells(4, 2).Value = Nom_entier
        Cells(1, 1).Value = "Poste : " + Poste
        Cells(1, j).Value = Dpt.Value
        Cells(2, j).Value = Date
        Cells(9, num_colonne).AutoFilter Field:=num_colonne, Criteria1:="1"
        'on masque toutes les colonnes inutiles
        indice = 3
        While Not indice = j
            Columns(indice).EntireColumn.Hidden = True
            indice = indice + 1
        Wend
Impression:
        i = 10
        Ind_TC = 0
        Dim Mem_TC(100) As Integer
        While Not Cells(i, 1).Value = ""
            If Cells(i, num_colonne) = 1 Then
                ' Recherche si la tâche étudiée est commune au CReG
                Tache_commune = 0
                k = 10
                While Not Worksheets("Tâches communes CReG").Cells(k, 1).Value = ""
                    If Worksheets("Tâches communes CReG").Cells(k, 1).Value = Cells(i, 1).Value Then
                        Tache_commune = 1
                    GoTo fin_boucle1
                    End If
                    k = k + 5
                Wend
fin_boucle1:
                ' Recherche si la tâche étudiée est commune aux Dpt AN/OP
                Tache_commune_AN_OP = 0
                k = 10
                While Not Worksheets("Tâches communes OP-AN").Cells(k, 1).Value = ""
                    If Worksheets("Tâches communes OP-AN").Cells(k, 1).Value = Cells(i, 1).Value Then
                        Tache_commune_AN_OP = 1
                        GoTo fin_boucle2
                    End If
                    k = k + 5
                Wend
fin_boucle2:
                Cells(i, 1).ClearContents
                Cells(i, 2).ClearContents
                If Tache_commune = 1 Then Cells(i, 2).Value = "Tâches Communes"
                If Tache_commune_AN_OP = 1 Then Cells(i, 2).Value = "Tâches Communes OP-AN"
                Cells(i + 1, 1).ClearContents
                Cells(i + 1, 2).ClearContents
                Cells(i + 3, 1).ClearContents
                Cells(i + 3, 2).ClearContents
                If Not Cells(i, j + 9).Value = "" Then Cells(i + 3, 2).Value = "Procédures : " + Cells(i, j + 9).Value
                Cells(i + 4, 1).ClearContents
                Cells(i + 4, 2).ClearContents
                If Not Cells(i, j + 10).Value = "" Then
                    Cells(i + 4, 2).Value = "Criticité intrinsèque : " + Cells(i, j + 10).Value
                    Mem_TC(Ind_TC) = i
                    Ind_TC = Ind_TC + 1
                End If
                If Cells(i, j + 4) > 6 Or Cells(i + 1, j + 4) > 7 Or Cells(i + 2, j + 4) > 7 _
                Or Cells(i + 3, j + 4) > 7 Or Cells(i + 4, j + 4) > 7 Or Cells(i, j + 7) = 1 Then
                    Cells(i + 4, 2).Value = "Tâche Critique"
                    If Ind_TC = 0 Then
                        Mem_TC(Ind_TC) = i
                        Ind_TC = Ind_TC + 1
                    End If
                    If Not Mem_TC(Ind_TC - 1) = i Then
                        Mem_TC(Ind_TC) = i
                        Ind_TC = Ind_TC + 1
                    End If
                End If
            End If
            i = i + 5
        Wend
impression2:
If TC_poste = True Then
    Sheets("TC-POSTE").Cells(9, 3) = Nom_entier
    Sheets("TC-POSTE").Cells(10, 3) = Nom_Dpt
    Sheets("TC-POSTE").Cells(11, 3) = Poste.Value
    Sheets("TC-POSTE").Cells(12, 3) = Date
    For l = 0 To lnd_TC - 1
        Sheets("TC-POSTE").Cells(l + 15, 1) = Cells(Mem_TC(l) + 2, 1).Value
        Sheets("TC-POSTE").Cells(l + 15, 2) = Cells(Mem_TC(l) + 2, 2).Value
        Sheets("TC-POSTE").Rows(l + 16).lnsert
        If l + 18 < 42 Then Sheets("TC-POSTE").Rows(l + 18).Delete
    Next l
    If Ind_TC > 23 And Ind_TC < 30 Then
        For j = 0 To 30 - Ind_TC
            Sheets("TC-POSTE").Rows(i + 18).Insert
        Next j
    End If
    Sheets(Array(Nom_Dpt, "TC-POSTE")).Select
End If
'Afficher la prévisualisation de l'impression
ActiveWindow.SelectedSheets.PrintPreview
'Impression de la fiche
'ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

If TC_poste = True Then
    Sheets(Nom_Dpt).Select
    Call effacer_TC_POSTE
End If

If Element_7 = True Then
j = j_memoire

'********************
' Elément N°7
' Création et Impression du dossier personnalisé des REGLEMENTS APPLICABLES AU POSTE


Dim FichierPère, FichierFils, Nom, Département, PostePersonne, Chemin, Valeur, Ligne, Colonne


' Nom du fichier source
FichierPère = ActiveWorkbook.Name

' Nom du fichier "Dossier personnalisé"
 FichierFils = "Elément 7 - dossier personnalisé.xls"

' Nom du collaborateur
Nom = Nom_entier

' Nom du département
Département = ActiveSheet.Name

' Type de poste
PostePersonne = Poste.Value

' Définition du chemin
Chemin = "H:\CDR\SIES\Element7-Réglements de l'organisation"
ChDir (Chemin)

' Ouverture du fichier Elément7 - dossier personnalisé
Workbooks.Open Filename:= _
    Chemin & "\" & FichierFils

' Création d'un onglet spécifique nommé dossier
Windows(FichierFils).Activate
Sheets("REGLES").Select
Sheets("REGLES").Copy Before:=Sheets(1)
Sheets("REGLES (2)").Select
Sheets("REGLES (2)").Name = "Dossier"

' Ecriture des règlements applicables au poste
Windows(FichierPère).Activate
Cells(9, 1).Select
While 0 = 0
    Windows(FichierPère).Activate
    Selection.End(xlDown).Select
    Test = 0
    If Selection.Value = "" Then GoTo SuitePoste
        Ligne = Selection.Row
        Colonne = Selection.Column
        Cells(Ligne, 2).Select
        Valeur = "Tâche '" + Selection.Value + "'"
        If Cells(Ligne + 2, 2).Value = "Tâche Critique" Then
            Test = Test + 1
            Valeur = Valeur + " (Tâche Critique)"
        End If
        If Cells(Ligne + 1, 2).Value <> "" Then
            Test = Test + 1
            Valeur = Valeur + " : " + Cells(Ligne - 2, j + 9).Value
        End If
        Cells(Ligne, Colonne).Select
        If Test = 0 Then GoTo SuiteBoucle
        Windows(FichierFils).Activate
        Sheets("Dossier").Select
        Range("B22:R22").Select
        Selection.Insert Shift:=xlDown
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
        Selection.Merge
        Selection.Interior.ColorIndex = xlNone
        With Selection
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = True
        End With
        Selection.Font.Bold = False
        Selection.Font.Size = 8
        Selection.Value = Valeur
SuiteBoucle:
Wend
SuitePoste:
    Range("A1").Select
    Windows(FichierFils).Activate
        
            ' Ecriture des règlements applicables au département
            Onglet = "R-" & Département
            Sheets(Onglet).Select
            Range("B11:R11").Select
            If Cells(12, 2).Value = "" Then GoTo SuiteDépartement
            Range(Selection, Selection.End(xlDown)).Select
SuiteDépartement:
            Selection.Copy
            Sheets("Dossier").Select
            Range("B19:R19").Select
            Selection.Insert Shift:=xlDown
                
            ' Ecriture des règlements applicables au Centre de Recherche
            Sheets("R-CReG").Select
            Range("B11:R11").Select
            If Cells(12, 2).Value = "" Then GoTo SuiteCReG
            Range(Selection, Selection.End(xlDown)).Select
SuiteCReG:
            Selection.Copy
            Sheets("Dossier").Select
            Range("B16:R16").Select
            Selection.Insert Shift:=xlDown
            
            ' Ecriture des paramètres personnels
            Sheets("Dossier").Select
            Range("F10").Value = Nom
            Range("F11").Value = Département
            Range("F12").Value = PostePersonne
            Range("F13").Value = Date
        
            ' Impression du dossier personnalisé
            Sheets("Dossier").Select
            ActiveCell.SpecialCells(xlLastCell).Select
            Range(Selection, Cells(1, 1)).Select
            ActiveSheet.PageSetup.PrintArea = Selection
            With ActiveSheet.PageSetup
                .CenterFooter = "REGLEMENTS DE L'ORGANISATION : ELEMENT N°7 / NOSE 801"
                .CenterHorizontally = True
                .CenterVertically = False
                .FooterMargin = Application.InchesToPoints(0.196850393700787)
                .Orientation = xlPortrait
                .Draft = False
                .PaperSize = xlPaperA4
                .FirstPageNumber = xlAutomatic
                .Order = xlDownThenOver
                .BlackAndWhite = False
                .Zoom = False
                .FitToPagesWide = 1
                .FitToPagesTall = 1
                .PrintErrors = xlPrintErrorsDisplayed
            End With
            'ActiveWindow.SelectedSheets.PrintPreview
            ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
        
Fin:

            ' Fermeture du fichier Elément7 - dossier personnalisé
            Windows(FichierFils).Activate
            ActiveWindow.Close (False)
        
            '***********
        End If

        'timer de qqs secondes --> valeur de s
        s = 5
        s = Timer + s
        While Timer < s
            DoEvents
        Wend

        If Not Choix_section = "" Then
            Columns(j).EntireColumn.Hidden = False
            'enlever l'option du filtre
            Columns(j).AutoFilter
            'supprimer la colonne correspondante à la présence de la tâche
            Columns(j - 1).Delete
            'remettre l'option du filtre
            Rows(9).AutoFilter
        End If
        Cells(1, 1).Select
    Next
Loop
    
End Sub
 
Trier par date Trier par votes
Re : VBA - Création de fiche individuelle + impression automatisée

Bonjour cissou,

plutôt qu'un long discours ( tous ce code que très peu parmis nous auront envie de lire jusqu'au bout)
il vaudrait mieux que tu joignes ton fichier avec explications plus claires et plus précises
fichier sans données confidentielles

à+
Philippe
 
Vote positif 0 Vote négatif
Re : VBA - Création de fiche individuelle + impression automatisée

Oui je sais qu'avec le fichier c'est bien plus clair et pratique mais il m'est impossible de supprimer toutes les données sensibles...
Après le code peut simplifier puisque certaines parties sont robustes et testées dans d'autre macro...

Je peux donc simplifier le code de la manière suivante :

Code: 
Private Sub OK_Click()
    Unload Me
 
    a = 1
    i = 3
      
Do While a <> "Expositions"
    a = Worksheets(Dpt.Value).Cells(9, i).Value
    i = i + 1
        
    For i = 3 To 5  '5 valeur fictive a modifier
    Worksheets(Dpt.Value).Cells(9, i).Value = "unique"
            
        For j = 1 To 500
            While "unique" <> Worksheets("Personne").Cells(j, 1).Value
                j_memoire = j
                Nom_entier = Worksheets("Personne").Cells(j, 2).Value + "" + Worksheets("Personne").Cells(j, 3).Value
                Poste = Worksheets("Personne").Cells(i, 8).Value
            Wend
        Next

'Macro adaptee pour la creation de la fiche individuelle
        
        Cells(2, 1).Value = "Inventorier par : " + Inventorier.Value
        Cells(3, 1).Value = "Personne concernée : " + Status
        Cells(4, 2).Value = Nom_entier
        Cells(1, 1).Value = "Poste : " + Poste
        Cells(1, j).Value = Dpt.Value
        Cells(2, j).Value = Date
        Cells(9, num_colonne).AutoFilter Field:=num_colonne, Criteria1:="1"
        'on masque toutes les colonnes inutiles
        indice = 3
        While Not indice = j
            Columns(indice).EntireColumn.Hidden = True
            indice = indice + 1
        Wend
Impression:
' le code semble robuste dans les autres macro... 
      

'timer de qqs secondes --> laisser un peu de temps au PC pour traiter l'impression
        s = 5
        s = Timer + s
        While Timer < s
            DoEvents
        Wend

        If Not Choix_section = "" Then
            Columns(j).EntireColumn.Hidden = False
            'enlever l'option du filtre
            Columns(j).AutoFilter
            'supprimer la colonne correspondante à la présence de la tâche
            Columns(j - 1).Delete
            'remettre l'option du filtre
            Rows(9).AutoFilter
        End If
        Cells(1, 1).Select
    Next
Loop
    
End Sub

J'espère que c'est plus lisible et digeste

Merci,
 
Vote positif 0 Vote négatif
Re : VBA - Création de fiche individuelle + impression automatisée

Comme demandé j'ai simplifié le fichier...

ci-après le lien de dl Free - Envoyez vos documents

L'idée est d'utiliser un numéro unique qui est propre à chaque personne (ligne 9 dans l'onglet Dpt 5 et première colonne dans l'onglet Personne).
A partir de cette donnée, on peut coupler les données telles que nom et prénom avec les taches que les personnes effectuent.

Donc j'essaye de créer une boucle pour chaque personne en incluant une étape de reconnaissance, une étape de réalisation de la fiche puis une étape d'impression.

Merci de votre aide 😉
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

K
  • Résolu(e)
XL 2016 Affichage TextBox
Réponses
6
Affichages
99
KRUG WOO
K
C
  • Question Question
XL 2021 VBA excel
Réponses
4
Affichages
79
CDALE
C
C
  • Question Question
Microsoft 365 worksheet_change
2
Réponses
29
Affichages
250
CortoXls
C
B
  • Question Question
XL 2019 Dans une macro de démarrage de fichier masquer le code par des Astérix ou point
Réponses
3
Affichages
92
sylvanu
sylvanu
A
  • Résolu(e)
XL 2016 Recherche d'un mot dans une cellule et surlignage de la ligne
Réponses
4
Affichages
108
Abi23
A
G
  • Résolu(e)
XL 2016 Pb de tri et sous totaux
2
Réponses
27
Affichages
334
Gestionnaire_rh
G
C
  • Question Question
XL 2021 Problème de remplissage d'une colonne conditionné à d'autres valeurs
Réponses
2
Affichages
432
CathyLD
C
T
  • Résolu(e)
XL 2016 macro et feuille protégé
2
Réponses
18
Affichages
736
laurent950
laurent950
D
  • Question Question
XL 2010 Recherche cellule vide sur une ligne
Réponses
9
Affichages
347
job75
job75
Nicolas JACQUIN
  • Question Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 K
Nicolas JACQUIN
Nicolas JACQUIN
M
  • Question Question
XL 2010 Aide à la suppression d'un produit en double dans un magasin spécifique avec conditions
Réponses
9
Affichages
792
Mody200
M
S
  • Résolu(e)
Microsoft 365 VBA Match: comment éviter l'erreur?
2
Réponses
29
Affichages
551
Dranreb
Dranreb
S
  • Résolu(e)
XL 2019 Problème de remplissage cellule en vba
Réponses
5
Affichages
395
snoopy07
S
P
  • Résolu(e)
XL 2013 EXCEL VBA
Réponses
2
Affichages
376
pangasoul
P
lynyrd
  • Question Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
599
AtTheOne
AtTheOne
M
  • Question Question
Microsoft 365 Erreur sur mon Code VBA
Réponses
2
Affichages
405
Gégé-45550
Gégé-45550
klin89
  • Question Question
Microsoft 365 Méthode Evaluate pour se dispenser d'une boucle imbriquée
Réponses
14
Affichages
396
patricktoulon
patricktoulon
P
  • Question Question
XL 2016 texte d'images vers excel
Réponses
14
Affichages
168
jurassic pork
jurassic pork
G
  • Résolu(e)
XL 2021 VBA dates au mauvais format
Réponses
5
Affichages
318
vgendron
vgendron
C
  • Résolu(e)
XL 2016 MsgBox avec critères
2
Réponses
22
Affichages
480
candido57
C
Retour