Enregistrement des onglets en fichier + un modèle

Fermé

Linoa - 17 mai 2017 à 16:51
Kalissi Messages postés 218 Date d'inscription jeudi 2 mai 2013 Statut Membre Dernière intervention 15 juillet 2019 - 19 mai 2017 à 15:16

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,

A voir également:

Enregistrement des onglets en fichier + un modèle
Fichier rar - Guide
Fichier host - Guide
Fichier iso - Guide
Comment réduire la taille d'un fichier - Guide
Comment ouvrir un fichier epub ? - Guide

4 réponses

Réponse 1 / 4

Kalissi Messages postés 218 Date d'inscription jeudi 2 mai 2013 Statut Membre Dernière intervention 15 juillet 2019 20
17 mai 2017 à 19:04

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

Réponse 2 / 4

Lino
18 mai 2017 à 14:16

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,

Réponse 3 / 4

Linoa
18 mai 2017 à 17:04

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,

Réponse 4 / 4

Kalissi Messages postés 218 Date d'inscription jeudi 2 mai 2013 Statut Membre Dernière intervention 15 juillet 2019 20
Modifié le 19 mai 2017 à 15:18

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

Discussions similaires

Question PIX

comment donner les droits sur fichier partage

Discussions similaires

Newsletters