Créer un classeur à partir de plusieurs données

Willkaa ,

Bon, je crois que cette voie est la bonne ! Et je préfère de loin ce code à l'ancien et le risque d'erreur est plus faible je trouve. Alors :

1) On fait une copie du classeur modele (enregistrer sous = saveas) en définissant d'entrée un nom.
2) on ouvre le nouveau classeur wbcahier et on parcourt toutes les feuilles du classeur.
3) pour la feuille en cours, si son index est inférieur à 6, on fait rien (ce sont les feuilles MENU à Listes). Sinon, si c'est une fiche, on regarde si le nom correspond à un modele. Si c'est le cas, on fait nos petites manips sur la feuille et sur la ligne. Sinon, on supprime la feuille.
4) Enfin, on modifie le bouton de la feuille répertoire.

Sub NouveauCahier()

Dim wbsource As Workbook, wbcahier As Workbook
Dim ws as worksheet
Dim rcahier As Range
Dim nomclasseur$
Dim i%

nomclasseur = "Cahier " & Format(Now, "YYMMDD-HHMM") & ".xlsm" 'nom classeur cahier à créer

Set wbsource = ThisWorkbook 'classeur origine 'classeur modele
wbsource.savecopyas Filename:=nomclasseur 'création nouveau cahier
set wbsource = nothing 'liberation modele
Set wbcahier = workbooks.open(nomclasseur) 'ouverture et affectation cahier
Set rcahier = wbcahier.Sheets("Répertoire Nouveau Cahier").Range("RepCahier") 'tableau des fiches nouveau cahier

Application.ScreenUpdating = False

for each ws in wbcahier.worksheets 'pour chaque feuille du cahier
    with ws 'sur feuille en cours
        if .index > 6 then 'si index > 6
            if application.countifs(rcahier.columns(2), .name, rcahier.columns(9), "") > 0 then 'si nom ws est dans col 2 et col9 vide
                i = Evaluate("SUMPRODUCT(MATCH(1, (RepCahier[Modèle]=""" & .Name & """) * (RepCahier[Lien]=""), 0))") 'position ligne corresp.
                .Name = rcahier(i, 1) 'renomme feuille
                if application.countifs(rcahier.columns(2), .name, rcahier.columns(9), "") > 1 then 'si plusieurs modeles identiques
                    .copy after:=ws 'copier modele en cours juste apres
                    Activesheet.name = rcahier(i, 2) 'renomme modele d'apres son nom de modele
                end if
                .Range(rcahier(i, 4)).Value = rcahier(i, 3) 'cellule à l'adresse en col 4 = valeur en col 3
                .Range(rcahier(i, 5)).Value = .Name 'cellule à l'adresse en col 5 = nouveau nom
                rcahier(i, 9).Hyperlinks.Add anchor:=rcahier(i, 9), Address:="", SubAddress:="'" & .Name & "'!A1", _
                ScreenTip:="Activez la feuille " & .Name, TextToDisplay:="Accès à la feuille : " & rcahier(i, 3)
            else
                Application.displayalerts = false
                .delete 'sinon, suppression feuille avec désact. alertes
                Application.displayalerts = true
            end if
        End If
    end with
Next

With wbcahier.Sheets("Répertoire Nouveau Cahier").Buttons(1) 'on modifie bouton feuille rep cahier
    .Text = "Mettre à jour les fiches" 'nv text
    .Name = "MAJCLASSEUR" 'nv nom
    .OnAction = "'" & nomclasseur & "'!LancerMajCahier" 'nvl macro affectée SUR CLASSEUR CAHIER
End With

Application.ScreenUpdating = True

'wbcahier.save 'sauvegarde
'wbcahier.Close True 'fermeture sauvegarde
Set rcahier = Nothing: Set wbcahier = Nothing 'liberation

End Sub

J'ai encore quelques incertitudes, notamment lors de la création de feuilles en cours de boucle sur la collection, pour la détermination de i qui ne marche pas sur mon mac et pour l'affectation de la nouvelle macro sur le bouton.

On va voir ce que ça donne.

Sacrée boulot! je ne sais pas comment tu peux sortir ce genre de code aussi long!

Euh.. comment dire...

J'ai copier et coller sur l'ancienne,

La macro ne plante pas mais rien ne se passe..

Ce genre de réponse me désespère... Bon, j'ai édité le code. Peux-tu réessayer ? Si possible, en fermant d'abord le classeur modele, en le renommant si son nom a changé, et l'ouvrant à nouveau.

J'ai répondu trop vite,

Il me créé bien un nouveau classeur mais comme c'est le m^me je n'avais pas vu!!

En effet le nom du bouton reste le même et le noms des fiches aussi !

Il m'a fermé le modèle.

En gros ça fait un copier fermé coller.

Salut Willkaa,

Alors, est-ce que tu as fait d'autres essais entre temps ? J'ai fait quelques essais de mon côté et ça semble marche correctement avec mon code édité. Voici tout de même une nouvelle version, que je ne peux pas tester jusqu'au bout avec mon mac malheureusement :

Sub NouveauCahier()

Dim wbsource As Workbook, wbcahier As Workbook
Dim rcahier As Range
Dim nomclasseur$
Dim i%, nbfeuilles%, x%

nomclasseur = "Cahier " & Format(Now, "YYMMDD-HHMM") & ".xlsm" 'nom classeur cahier à créer

Set wbsource = ThisWorkbook 'classeur origine 'classeur modele
wbsource.SaveCopyAs Filename:=nomclasseur 'création nouveau cahier
Set wbsource = Nothing 'liberation modele
Set wbcahier = Workbooks.Open(nomclasseur) 'ouverture et affectation cahier
Set rcahier = wbcahier.Sheets("Répertoire Nouveau Cahier").Range("RepCahier") 'tableau des fiches nouveau cahier

Application.ScreenUpdating = False

With wbcahier
    nbfeuilles = .Worksheets.Count
    For x = 1 To nbfeuilles 'pour chaque feuille du cahier
        With .Sheets(x) 'sur feuille en cours
            If .Index > 6 And Application.CountIf(rcahier.Columns(1), .Name) = 0 Then 'si index > 6
                If Application.CountIfs(rcahier.Columns(2), .Name, rcahier.Columns(9), "") > 0 Then 'si nom ws est dans col 2 et col9 vide
                    i = Evaluate("SUMPRODUCT(MATCH(1, (RepCahier[Modèle]=""" & .Name & """) * (RepCahier[Lien]=""), 0))") 'position ligne corresp.
                    .Name = rcahier(i, 1) 'renomme feuille
                    If Application.CountIfs(rcahier.Columns(2), rcahier(i, 2), rcahier.Columns(9), "") > 1 Then 'si plusieurs modeles identiques
                        .Copy after:=wbcahier.Sheets(x) 'copier modele en cours juste apres
                        ActiveSheet.Name = rcahier(i, 2) 'renomme modele d'apres son nom de modele
                    End If
                    .Range(rcahier(i, 4)).Value = rcahier(i, 3) 'cellule à l'adresse en col 4 = valeur en col 3
                    .Range(rcahier(i, 5)).Value = .Name 'cellule à l'adresse en col 5 = nouveau nom
                    rcahier(i, 9).Hyperlinks.Add anchor:=rcahier(i, 9), Address:="", SubAddress:="'" & .Name & "'!A1", _
                    ScreenTip:="Activez la feuille " & .Name, TextToDisplay:="Accès à la feuille : " & rcahier(i, 3)
                Else
                    Application.DisplayAlerts = False
                    .Delete 'sinon, suppression feuille avec désact. alertes
                    Application.DisplayAlerts = True
                    x = x - 1
                End If
            End If
        End With
        nbfeuilles = .Worksheets.Count
    Next
    With .Sheets("Répertoire Nouveau Cahier").Buttons(1) 'on modifie bouton feuille rep cahier
        .Text = "Mettre à jour les fiches" 'nv text
        .Name = "MAJCLASSEUR" 'nv nom
        .OnAction = "'" & nomclasseur & "'!LancerMajCahier" 'nvl macro affectée SUR CLASSEUR CAHIER
    End With
End With

Application.ScreenUpdating = True

'wbcahier.save 'sauvegarde
'wbcahier.Close True 'fermeture sauvegarde
Set rcahier = Nothing: Set wbcahier = Nothing 'liberation

End Sub

On va y arriver petit à petit. L'idéal serait déjà de passer la ligne de l'affectation de i.

Voici

Sub DeprotegerFeuilles()

Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets
    If ws.Name Like "AV*" Then
        ws.Unprotect "AVE"
    End If
Next ws

End Sub

Sub ProtegerFeuilles()

Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets
    If ws.Name Like "AV*" Then
        ws.Protect "AVE" 'choisir les paramètres de protection https://docs.microsoft.com/fr-fr/office/vba/api/excel.worksheet.protect
    End If
Next ws

End Sub

par ailleurs 2 codes pour la protection, déprotection (à adapter probablement) :

Et pour moi, une petite macro à voir après (si la création du nouveau classeur se passe bien) :

Sub DeplacerFeuilles()

Dim ws As Worksheet
Dim position%

With ActiveWorkbook
    For Each ws In .Worksheets
        If ws.Name Like "AV*" Then
            position = Right(ws.Name, 2) + 6
            If position < .Worksheets.Count Then
                ws.Move before:=.Sheets(position + 1)
            Else
                ws.Move after:=.Sheets(.Sheets.Count - 1)
            End If
        End If
    Next ws
End With

End Sub

A bientôt,

Bonjour à toi 3GB,

Tu as passé un bon weekend? Désolé pour mon absence, j'ai profité du beau temps pour faire quelques bricoles dans ma cour :)

Alors oui j'ai fait plusieurs test et commencé à retranscrire des choses sur mon projet de base,

Alors j'ai copier celle ci, et essayer, donc il m'ouvre un nouveau cahier, "date-heure" laisse le classeur modèle ouvert, et bloque à "i" comme tu le pressentais..

Erreur d'éxécution '13'

Incompatibilité de type

Salut Willkaa,

Oui j'ai passé un bon week-end... mais de confiné. Et je suis en appartement malheureusement. Je suis content de savoir que tu peux quand même t'aérer malgré les restrictions.

Sais-tu à quelle valeur de x l'erreur s'est produite ? En fait, il faudrait tester le code au pas à pas en ouvrant (si elle n'est pas déjà ouverte) la fenêtre variables locales via le menu affichage. Ensuite tu exécutes la macro mais en appuyant à répétition sur la touche F8. Ça permet de réaliser les étapes à son rythme et de voir les valeurs que prennent les variables notamment.
Tu peux aussi marquer des points d'arrêt (en cliquant sur la petite marge à gauche de le fenêtre de code : une ligne marron doit apparaitre) au niveau des lignes clés. Tu peux ainsi alterner l'exécution normale (F5) et le pas à pas (F8).

Sinon, pourrais-tu m'envoyer la dernière version de ton fichier modèle, sans protection. Quand j'aurai un moment, je ferai des essais sur windows.

Bonjour 3GB,

Ah oui . désolé.. Il est vraiment temps qu'ils trouvent une solution à tout ça..

Alors je vais essayer de faire par étapes et je reviens vers toi. J'ai une version 5 avec lequel on traite, et une version 4 avec toutes les infos complétés(Société, Nom, Adresse.. ) avec ancienne macro.

Je t'envoie la V5 sans protection

Je n'y comprends rien à tout cela, mais si ça peux t'aider la valeur de "x" = 7 au moment du bogage

Salut Willkaa,

Je suis partant pour la solution 5. Mais comme je t'ai dit, je ne pourrais tester que lorsque je serai sur windows et que j'aurai du temps (ces 2 conditions sont rarement réunies).

Peux-tu essayer ceci en attendant :

Sub NouveauCahier()

Dim wbsource As Workbook, wbcahier As Workbook
Dim rcahier As Range
Dim nomclasseur$, expr$
Dim i%, nbfeuilles%, x%

nomclasseur = "Cahier " & Format(Now, "YYMMDD-HHMM") & ".xlsm" 'nom classeur cahier à créer

Set wbsource = ThisWorkbook 'classeur origine 'classeur modele
wbsource.SaveCopyAs Filename:=nomclasseur 'création nouveau cahier
Set wbsource = Nothing 'liberation modele
Set wbcahier = Workbooks.Open(nomclasseur) 'ouverture et affectation cahier
Set rcahier = wbcahier.Sheets("Répertoire Nouveau Cahier").Range("RepCahier") 'tableau des fiches nouveau cahier

Application.ScreenUpdating = False

With wbcahier
    nbfeuilles = .Worksheets.Count
    For x = 1 To nbfeuilles 'pour chaque feuille du cahier
        With .Sheets(x) 'sur feuille en cours
            If .Index > 6 And Application.CountIf(rcahier.Columns(1), .Name) = 0 Then 'si index > 6
                If Application.CountIfs(rcahier.Columns(2), .Name, rcahier.Columns(9), "") > 0 Then 'si nom ws est dans col 2 et col9 vide
                    expr = "SUMPRODUCT(MATCH(1, (RepCahier[Modèle]=""" & .Name & """) * (RepCahier[Lien]=""), 0))"
                    i = Evaluate(expr) 'position ligne corresp.
                    .Name = rcahier(i, 1) 'renomme feuille
                    If Application.CountIfs(rcahier.Columns(2), rcahier(i, 2), rcahier.Columns(9), "") > 1 Then 'si plusieurs modeles identiques
                        .Copy after:=wbcahier.Sheets(x) 'copier modele en cours juste apres
                        ActiveSheet.Name = rcahier(i, 2) 'renomme modele d'apres son nom de modele
                    End If
                    .Range(rcahier(i, 4)).Value = rcahier(i, 3) 'cellule à l'adresse en col 4 = valeur en col 3
                    .Range(rcahier(i, 5)).Value = .Name 'cellule à l'adresse en col 5 = nouveau nom
                    rcahier(i, 9).Hyperlinks.Add anchor:=rcahier(i, 9), Address:="", SubAddress:="'" & .Name & "'!A1", _
                    ScreenTip:="Activez la feuille " & .Name, TextToDisplay:="Accès à la feuille : " & rcahier(i, 3)
                Else
                    Application.DisplayAlerts = False
                    .Delete 'sinon, suppression feuille avec désact. alertes
                    Application.DisplayAlerts = True
                    x = x - 1
                End If
            End If
        End With
        nbfeuilles = .Worksheets.Count
    Next
    With .Sheets("Répertoire Nouveau Cahier").Buttons(1) 'on modifie bouton feuille rep cahier
        .Text = "Mettre à jour les fiches" 'nv text
        .Name = "MAJCLASSEUR" 'nv nom
        .OnAction = "'" & nomclasseur & "'!LancerMajCahier" 'nvl macro affectée SUR CLASSEUR CAHIER
    End With
End With

Application.ScreenUpdating = True

'wbcahier.save 'sauvegarde
'wbcahier.Close True 'fermeture sauvegarde
Set rcahier = Nothing: Set wbcahier = Nothing 'liberation

End Sub

Refaire un test et me copier la valeur de la variable expr lors du bug ?

Merci...

Et x = 7, c'est l'index de la feuille. Ça veut dire que ça bug à la 7è, soit la première de AV (ce qui confirme que le problème réside uniquement sur la ligne i = evaluate).

Ca marche,

Alors voici après un deuxième essai:

A ce niveau il prend encore les ancien nom c'est peut être pour ça?Je vais mettre que 3 feuilles modèles dans le répertoire pour commencer,

En gros il beugue a la première fiche recherchée du répertoire

Non, c'est le but qu'il prenne les anciens noms, c'est la formule qui est pas bonne au niveau du RepCahier[Lien] = "", moi qui étais focalisé sur le RepCahier[Modèle]...

Peux-t essayer comme ça :

expr = "SUMPRODUCT(MATCH(1, (RepCahier[Modèle]=""" & .Name & """) * (RepCahier[Lien]=""""), 0))"

On va y arriver bientôt !

Le pire c'est que j'ai oublié mon chargeur de PC je l'aurai que demain, donc 1h30 d'autonomie..

Mais le code est le même ?

Comment ça expr vaut "Faux" ?

T'inquiète, on en aura fini en bien moins d'une heure et demie (si seulement) !

Non, le code est pas le même, j'ai rajouté des guillemets pour que la chaîne vide soit lue comme telle.

Erreur de syntaxe de ma part ..

J'au un nouveau classeur avec les nouveau nom et les liens !

Chez moi, ça marche (bon il y a une erreur après mais c'est déjà bien !) donc ce n'était pas un problème de version mais d'attention de ma part, quel c*n !

Ah c'est pas moi qui l'ai dit Surtout que je suis incapable de réparé ça tout seul!

La il plante ailleurs il a passé le cap du "i"

C'est bon, j'ai trouvé ! Reste plus qu'à les mettre en ordre (car la macro que j'avais préparée marche pas assez bien...), j'y travaille !

Je suis assez fier de moi !