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

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 :mad:
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
 

phlaurent55

Nous a quittés en 2020
Repose en paix
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
 

cissou69

XLDnaute Junior
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,
 

cissou69

XLDnaute Junior
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 ;)
 

Discussions similaires

Statistiques des forums

Discussions
311 724
Messages
2 081 936
Membres
101 844
dernier inscrit
pktla