Enregistrement des onglets en fichier + un modèle Fermé

Question

Bonjour,

J’ai un classeur qui reprend l’historique des augmentations, promotions… accordées aux salariés (environ 2000).

Dans un premier temps je crée à chaque changement de service (colonne L) un onglet avec le numéro de service comme nom. Ensuite j’enregistre chacune des feuilles dans un classeur à part.

Voici en code :

Sub creation_onglets()
Dim contenu As String
Dim lig As Long, derlig As Long
With Sheets("HIST")
    derlig = .Range("L" & Rows.Count).End(xlUp).Row
    For lig = 2 To derlig
        contenu = .Cells(lig, 12).Value
        If contenu = "" Then GoTo Suite 
        If FeuilleExiste(ThisWorkbook, contenu) Then
            .Rows(lig).Copy Sheets(contenu).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        Else
            Sheets.Add
            ActiveSheet.Name = contenu
            .Rows(1).Copy Sheets(contenu).Range("A1") 
            .Rows(lig).Copy Sheets(contenu).Range("A2") 
        End If
Suite:
    Next lig
End With
End Sub

Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean
 On Error Resume Next
 FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing)
End Function

Sub saveOnglet()
Dim ws
Dim newWk As Workbook
    For Each ws In Worksheets
        Set newWk = Workbooks.Add(xlWBATWorksheet)
        ws.Copy newWk.Sheets(1)
        newWk.SaveAs ("H" & ws.Name & ".xlsx")
        newWk.Close
        Set newWk = Nothing
    Next ws


End Sub

Ensuite manuellement pour chaque historique de service (plus de 100 fichiers) j’insère une feuille, je nomme ma plage de donnée, je protège classeur et feuille…

Ma question est : serait-il possible de faire en sorte qu’à l’enregistrement de tous les fichiers les étapes manuelles soient exécutées ?

Etant débutant en VBA je prends des bouts de code sur les forums..., il est donc possible que les codes ci-haut ne soient par « optimums ».

Merci de votre aide et compréhension,

Kalissi · Answer

Bonjour,

Outre le GOTO que je ne conseille pas :

Option Explicit

Sub Creation_Onglets()

Dim contenu As String
    Dim lig As Long, derlig As Long

With Sheets("HIST")
     derlig = .Range("L" & Rows.Count).End(xlUp).Row
     For lig = 2 To derlig
        contenu = .Cells(lig, 12).Value
        If Not contenu = "" Then
            If FeuilleExiste(ThisWorkbook, contenu) Then
                .Rows(lig).Copy Sheets(contenu).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            Else
                Sheets.Add
                ActiveSheet.Name = contenu
                .Rows(1).Copy Sheets(contenu).Range("A1")
                .Rows(lig).Copy Sheets(contenu).Range("A2")
            End If
        End If
     Next lig
    End With
    
End Sub
'

Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean
 On Error Resume Next
 FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing)
End Function
'

Sub SaveOnglet()

Dim ws As Worksheet
    Dim newWk As Workbook

For Each ws In Worksheets
        Set newWk = Workbooks.Add(xlWBATWorksheet)
        ws.Copy newWk.Sheets(1)
        newWk.SaveAs ("H" & ws.Name & ".xlsx")
        newWk.Close
        Set newWk = Nothing
     Next ws

End Sub

Oui, tu peux effectuer les manipulations par VBA.

1.) Place toi au début des manipulations manuelles
2.) Lance l'enregistreur de macro
3.) Effectue les opérations manuelles
4.) Arrête l'enregistreur de macro.

Va voir le code généré et insère celui-ci dans la boucle de sauvegarde.
S'il te faut de l'aide, copie/colle le code ici et il sera possible de t'aider pour le fignolage.

K

Lino · Answer

OK déjà merci pour cette première réponse !
Pensant que ce n'était pas possible je suis un peu prise au dépourvu... Je mets rapidement le résultat de l'enregistrement.

Encore merci,

Linoa · Answer

Re bonjour,

Voici ce que donne l'enregisteur de Macro, sachant que je suis parti d'un fichier (A-4511) généré par la macro SaveOnglet :


Sub Macro()

    Sheets("A-4511").Select
    Sheets("A-4511").Name = "OUTIL"
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Names.Add Name:="NUMAGENT", RefersToR1C1:= _
        "=OUTIL!R2C1:R100C1"
    Sheets("OUTIL").Select
    ActiveWindow.SelectedSheets.Visible = False

    Windows("Modele.xlsx").Activate
    Sheets("PROPOSITIONS").Select
    Sheets("PROPOSITIONS").Copy Before:=Workbooks("A-4511.xlsx").Sheets(2)
    Range("B11").Select
    ActiveCell.FormulaR1C1 = "=OUTIL!R[-9]C[6]"
    Range("E11").Select
    ActiveCell.FormulaR1C1 = "=OUTIL!R[-9]C"
    Range("A17:A40").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=NUMAGENT"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
    Range("A17").Select
    ActiveWorkbook.Protect Structure:=True, Windows:=False
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingColumns:=True, AllowFormattingRows:=True
End Sub

Si j'essaye de m'expliquer :
1/ Mettre OUTIL a la place des numéros de service 
2/ Prendre l'ensemble des données en A pour créer une plage nommé NUMAGENT
3/ Masquer la feuille OUTIL
4/ En B11 formule OUTIL!H2
5/ En B11 formule OUTIL!G2
6/ Sur la feuille PROPOSITIONS de A17:A40 liste déroulante avec la plage NUMAGENT
7/ Protéger la feuille
8/ Protéger le classeur

Merci 1000 fois,

Kalissi · Answer

Bonjour,

Je ne suis pas sur de bien comprendre mais enfin, voici le résultat :

En supposant que le fichier contenant tous les onglets se nomme Historique.xlsx

Option Explicit
'

Global Maitre As Workbook

Sub Creation_Onglets()

Dim contenu As String
    Dim lig As Long, derlig As Long

With Sheets("HIST")
     derlig = .Range("L" & Rows.Count).End(xlUp).Row
     For lig = 2 To derlig
        contenu = .Cells(lig, 12).Value
        If Not contenu = "" Then
            If FeuilleExiste(ThisWorkbook, contenu) Then
                .Rows(lig).Copy Sheets(contenu).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            Else
                Sheets.Add
                ActiveSheet.Name = contenu
                .Rows(1).Copy Sheets(contenu).Range("A1")
                .Rows(lig).Copy Sheets(contenu).Range("A2")
            End If
        End If
     Next lig
    End With
    
End Sub
'

Function FeuilleExiste(ByVal wk As Workbook, ByVal stFeuille As String) As Boolean
    On Error Resume Next
    FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing)
End Function
'

Sub SaveOnglet()

Dim ws As Worksheet
    Dim newWk As Workbook
    Dim NomFle As String

Workbooks("Historique.xlsm").Activate
    Set Maitre = ActiveWorkbook

For Each ws In Worksheets
       Set newWk = Workbooks.Add(xlWBATWorksheet)
       ws.Copy newWk.Sheets(1)
       NomFle = ActiveSheet.Name
       Manipulation NomFle
       ActiveWorkbook.Save
       newWk.Close
       Set newWk = Nothing
       Maitre.Activate
    Next ws

End Sub
'

Sub Manipulation(ByVal pNomFle As String)

ActiveWorkbook.SaveAs ("H" & pNomFle & ".xlsx")
    Sheets(pNomFle).Select
    Sheets(pNomFle).Name = "OUTIL"
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Names.Add Name:="NUMAGENT", RefersToR1C1:="=OUTIL!R2C2:R100C1"
    Sheets("OUTIL").Select
    ActiveWindow.SelectedSheets.Visible = False

Windows("Modele.xlsx").Activate
    Sheets("PROPOSITIONS").Select
    Sheets("PROPOSITIONS").Copy Before:=Workbooks("H" & pNomFle & ".xlsx").Sheets(2)
    Range("B11").Select
    ActiveCell.FormulaR1C1 = "=OUTIL!R[-9]C[6]"
    Range("E11").Select
    ActiveCell.FormulaR1C1 = "=OUTIL!R[-9]C"
    Range("A17:A40").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=NUMAGENT"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
    Range("A17").Select
    ActiveWorkbook.Protect Structure:=True, Windows:=False
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True
        
End Sub


K