Créer un classeur à partir de plusieurs données
Je suis en admiration en ce qui me concerne, si je pouvais connaitre tout cela!
Bon, bon, bon, bon !!!!
Je crois qu'on tient quelque chose de pas trop mal !
Alors, désolé, je vais t'envoyer la dernière version que j'avais avec les codes corrompus à cause des accents et de mon mac. Je vais quand même poster les codes pour que tu puisses les copier. Bon, comme j'ai fait plein de petites modifs, le code n'est pas nickel mais au moins fonctionnel (sauf cas que je n'aurais pas testé).
Il demeure cependant un petit blocage lors de la mise à jour du nouveau cahier : il faut que le classeur modèle soit ouvert. Alors, je ne sais pas si c'est à cause de ma version mais c'est assez secondaire et on pourra regarder ça plus tard...
Alors voici le fichier dans un premier temps. N'hésite pas à faire des tests dans tous les sens !
NB : Une fois que tu auras décidé d'un nom final (à ce classeur modèle), il faudra le saisir en dur dans le code dans le module MAJCLASSEUR, macro MajCahierInsertion, ligne nomclasseur.
MODULE CreationClasseur
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
If x >= nbfeuilles Then Exit For
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
Call DeplacerFeuilles
Application.ScreenUpdating = True
'wbcahier.save 'sauvegarde
'wbcahier.Close True 'fermeture sauvegarde
Set rcahier = Nothing: Set wbcahier = Nothing 'liberation
End Sub
Function FeuilleExiste(Classeur As Workbook, NomFeuille As String) As Boolean 'fonction testant existence feuille
On Error Resume Next
FeuilleExiste = Classeur.Sheets(NomFeuille).Index
End Function
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"
End If
Next ws
End Sub
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)
Else
ws.Move after:=.Sheets(.Sheets.Count)
End If
End If
Next ws
End With
End SubModule MAJCLASSEUR
Option Base 1
Sub LancerMajCahier()
Call MajCahierSuppression
Call MajCahierInsertion
End Sub
Sub MajCahierSuppression() 'suppression en rafale des feuilles correspondant à des lignes supprimées du répertoire (macro exclusivement sur classeur courant, à utiliser dans nouveau cahier)
Dim wsrep As Excel.Worksheet
Dim rnvcahier As Excel.Range
Dim FeuilleReste()
Dim i%, n%, j%, nbfeuilles%
Dim conserver As Boolean
Set wsrep = Sheets("Répertoire Nouveau Cahier") 'feuille repertoire nouveau cahier
Set rnvcahier = wsrep.Range("RepCahier") 'tableau liste fiches nouveau cahier
Application.ScreenUpdating = False 'désactive maj écran
For i = 1 To rnvcahier.Rows.Count
If Not rnvcahier(i, 9) = "" Then
n = n + 1
ReDim Preserve FeuilleReste(n)
FeuilleReste(n) = Replace(Replace(rnvcahier(i, 9).Hyperlinks(1).SubAddress, "!A1", ""), "'", "")
With rnvcahier(i, 9).Hyperlinks(1)
.SubAddress = "'" & rnvcahier(i, 1) & "'!A1"
.ScreenTip = "Activez la feuille " & rnvcahier(i, 1).Value
.TextToDisplay = "Accès à la feuille : " & rnvcahier(i, 3).Value
End With
End If
Next i
nbfeuilles = Sheets.Count
If nbfeuilles > 6 Then
For i = 7 To nbfeuilles
For j = 1 To n
If Sheets(i).Name = FeuilleReste(j) Then conserver = True
Next j
If Not conserver Then
Application.DisplayAlerts = False
Sheets(i).Delete
Application.DisplayAlerts = True
i = i - 1
End If
conserver = False
nbfeuilles = Sheets.Count
If i >= nbfeuilles Then Exit For
Next i
End If
If nbfeuilles > 6 Then
For i = 7 To nbfeuilles
If Not Sheets(i).Name = "AV-" & Format(i - 6, "000") Then
Sheets(i).Name = "AV-" & Format(i - 6, "000")
End If
Next i
End If
Application.ScreenUpdating = True 'réactive maj ecran
Set rnvcahier = Nothing: Set wsrep = Nothing 'liberation variables
'RQ : cette macro n'agit donc que sur le classeur executant _
elle permet d'eviter les lignes du tableau de fiches n'ayant pas de valeur dans la colonne lien (notamment celles qui ont été insérées)
End Sub
Sub MajCahierInsertion()
Dim wbcahier As Excel.Workbook, wbsource As Excel.Workbook
Dim wsrep As Excel.Worksheet
Dim rnvcahier As Excel.Range
Dim nomclasseur$
Dim i%, num%
nomclasseur = "1-cahier-de-controle-test-v3.xlsm" '<<<<METTRE CHEMIN DU CLASSEUR MODELE
Set wbcahier = ThisWorkbook 'classeur executant (nouveau cahier)
Set wsrep = wbcahier.Sheets("Répertoire Nouveau Cahier") 'feuille repertoire nv cahier
Set rnvcahier = wsrep.Range("RepCahier") 'tableau fiches
Application.ScreenUpdating = False
If Application.CountIfs(rnvcahier.Columns(1), "<>", rnvcahier.Columns(9), "") > 0 Then 'si nb lignes avec fiche remplie et lien vide > 0
On Error Resume Next 'en cas d'erreur, continuer (au cas ou classeur modele est fermé)
Set wbsource = Workbooks(nomclasseur) 'classeur modele
If Err.Number = 9 Then 'si erreur : indice nappartient pas a la selection (classeur modele ferme)
Err.Clear 'effacer les erreurs
Application.DisplayAlerts = False
Set wbsource = worbooks.Open(nomclasseur) 'ouverture du classeur modele (SUGGERE UN CHEMIN CORRECT, sinon, rajouter gestion erreur 1004 puis forcer sortie procedure)
Application.DisplayAlerts = True
End If
With wbcahier 'avec nv classeur
For i = 1 To rnvcahier.Rows.Count 'pour chaque lignes des fiches nv classeur
If rnvcahier(i, 1).Value <> "" And rnvcahier(i, 9).Value = "" Then 'si fiche remplie et lien vide (donc ligne inseree)
num = Right(rnvcahier(i, 1).Value, 2) + 6 'num = index feuille concernee = droite fiche + 6
wbsource.Sheets(rnvcahier(i, 2).Value).Copy after:=.Sheets(num - 1) 'copie feuille du classeur modele a l'index num
With .Sheets(num) 'avec feuille num (feuille inseree a linstant)
.Range(rnvcahier(i, 4).Value).Value = rnvcahier(i, 3).Value 'cellule a l'adresse addid = identification
.Range(rnvcahier(i, 5).Value).Value = rnvcahier(i, 1).Value 'cellule a l'adresse desti = nouveau nom
rnvcahier(i, 9).Hyperlinks.Add anchor:=rnvcahier(i, 9), Address:="", _
SubAddress:="'" & rnvcahier(i, 1) & "'!A1", _
ScreenTip:="Activez la feuille " & rnvcahier(i, 1).Value, _
TextToDisplay:="Accès à la feuille : " & rnvcahier(i, 3).Value 'ajout hypertexte en colonne lien pointant sur feuille num
.Buttons(1).OnAction = "'" & wbcahier.Name & "'!AllerRepertoire"
.Buttons(2).OnAction = "'" & wbcahier.Name & "'!AllerReserve"
End With
End If
Next i
For i = .Sheets.Count To 6 Step -1 'de la derniere feuille à la feuille 6
If .Sheets(i).Name Like "AV*" Then 'si feuille commence par AV
.Sheets(i).Name = Left(.Sheets(i).Name, 3) & Format(i - 6, "000") 'nom feuille = prefixe & suffixe = racine nom feuille & index feuille - 6 (car 6 feuilles fixes)
End If
Next i
End With
End If
'wbsource.Close savechanges:=True 'ferme et sauve
Application.ScreenUpdating = True
Set rnvcahier = Nothing: Set wsrep = Nothing: wbsource = Nothing: Set wbcahier = Nothing
End SubLes autres modules n'ont pas changé.
Bon les commentaires ne sont plus trop à jour... Peut-être que je repasserais sur ces codes pour les clarifier et essayer de les améliorer.
Mais là
A bientôt,
Bonjour 3GB,
Très bien alors je vais aller mettre à jour tout ca, je reviens vers toi pour te dire ce qu'il en est.
Alors j'espere que tu tiens un petit virus, en attendant soigne toi bien!
@+ et bon rétablissement,
Salut Willkaa,
Merci de ton retour, je m'impatientais !
Non aucun virus fort heureusement, c'était pour dire que toutes ces petites modifs m'ont fait mal à la tête donc j'ai un peu négligé la rigueur à la fin...
A bientôt avec de bonnes nouvelles j'espère,
Bonjour 3GB!
J'èspère que tout va bien!
Alors j'ai ouvert la version 4b et fais quelques essais...Et j'ai comme l'impression que tout fonctionne à merveille!!!!!!!!!!!
C'est super! Je réitère mon compliment comme quoi tu es un génie du VBA!
Alors cette semaine je suis en Congé je vais essayé de trouver du temps pour coller tout cela avec ma version définitive, mais je pense que ça ne devrai pas poser de problème!
Je reviens vers toi dès que j'ai monté tout ca! Tu vas pouvoir reposer tes neuronnes!
A très bientôt!
Salut Willkaa !
Super !
Si seulement j'en étais un
Ok, j'attends donc ton retour. Sois bien vigilant au nom du classeur modèle à saisir dans le code. Et pour mettre à jour le nouveau cahier, il faudra bien s'assurer toujours d'ajouter les infos nécessaires sauf le lien hypertexte (pour insérer une nouvelle fiche) ou de supprimer toutes les valeurs dont le lien hypertexte (pour supprimer une fiche).
A bientôt alors et bonne semaine de congé !
Bonjour 3GB,
Je suis de retour!! J’espère que tout va pour le mieux ?!
Alors j'essai de mettre en forme qles trucs bon je t'avoue je galère..
JE crois que j'ai remarqué une anomalie... désolé..
Il s'avère que quand je modifie le classeur nouveau avec la mise à jour, le nom des feuilles ne suit pas, il reste figé sur l'ancien nom.
J'ai une petite question aussi je dois rajouter en index 3 feuilles, je suppose que du coup deux trois choses devront changés dans les macro?
Salut Willkaa,
Tout va bien, je te remercie. J'espère que pour toi aussi et que tu as bien profité de ta semaine de repos.
Tu essaies de mettre en forme quelques trucs ?
Je n'ai pas bien compris l'anomalie ? Que se passe-t-il exactement ? Quand est-ce que ça se passe ? Ca fait plus d'une semaine maintenant donc tout ça n'est plus parfaitement frais dans mon esprit.
Que veux-tu dire par rajouter en index 3 feuilles ? Si tu rajoutes des fiches, en principe, il n'y a rien à changer. Si en revanche, tu rajoutes des onglets "généraux", il faudra en effet adapter le code et remplacer 6 et 7 respectivement par 9 et 10.
J'ai pas trop eu le temps de me reposer, j'ai pas mal de bricole à faire à la maison alors j'en profites quand j'ai du temps :)
Concernant l'anomalie, j'appuie sur le bouton création de cahier, ce qui m'ouvre un autre classeur, ensuite quand je supprime une ligne, dans le répertoire de ce nouveau classeur, et que j'appuie sur mise à jour, le répertoire se met bien à jour les feuilles concernées disparaissent, le nom des onglets aussi mais leurs noms en "F6" ( AV-00..) ne suivent pas.
J'ai bien noter concernant les onglets généraux, je vais essayer de trouver les bon "6"
Concernant la mise en forme j'essaie d'intégrer soit tes codes dans mon classeur, soit conserver celui qui fonctionne (le dernier que tu m'as envoyé) et y insérer toutes mes pages mais malheureusement il y a toujours quelques choses qui ne va pas avec les index dans les formules ou du coup dans les codes.. .. enfin ce n'est qu'un détails ça... avec le temps je devrai y arriver..Ca serai plus simple si tu voyais mon tableau avec toutes ses feuilles (60) et ce que je veux faire mais ça va faire lourd..il va falloir que tu m'expliques une chose sur la création index dans les tableaux et comment les insérés dans les formules..
Comment supprimes-tu les lignes ? Est-ce que tu effaces les contenus sur les cases A à I ou est-ce que tu supprimes la ligne ?
Pour la mise en forme, je ne sais pas mais les formules INDEX portent probablement sur un tableau nommé ? Si le la formule est copiée mais que le nom du tableau n'est pas le bon, ça peut bloquer...
il va falloir que tu m'expliques une chose sur la création index dans les tableaux et comment les insérés dans les formules..
Peux-tu être plus précis ? Comme on parle à la fois d'index de feuille, de la fonction index, je ne sais pas de quoi tu parles exactement. En tout cas, n'hésite pas à poser tes questions
Dans le répertoire je supprime la ligne, il ne faut pas ?
Pour les index on voit ça des qu'on a résolu 2/3 petites choses dans ce classeur:)
La je suis partie de ton dernier fichier que tu m'as envoyé du coup, j'ai ajouté toutes mes feuilles remplacé mes formules et il plante dès le début :
Ah c'est bon je pense que c'est du à un bug du PC..
Donc j'ai relancer le process pour voir, Cela fonctionne jusqu'a ce que je modifie le nouveau répertoire,
Il créé le lien, dans le répertoire mais il ne me rajoute plus les nouvelles feuilles..
Alors, c'est étrange.
Ca fait comme si tu l'avais déjà créé puis tu essayais de le rouvrir ensuite alors qu'il est déjà ouvert.
Qu'en est-il ? Tu as essayé de créé un second cahier ? Si c'est le cas, pour pallier ce problème, on peut modifier la "première" ligne comme ceci :
nomclasseur = "Cahier " & Format(Now, "YYMMDD-HHMMSS") & ".xlsm" 'nom classeur cahier à créerAvec les secondes, on ne devrait plus avoir de problème.
RE:Ah c'est bon je pense que c'est du à un bug du PC..
Donc j'ai relancer le process pour voir, Cela fonctionne jusqu'a ce que je modifie le nouveau répertoire,
Il créé le lien, dans le répertoire mais il ne me rajoute plus les nouvelles feuilles.. Je vais jamais y arriver ..
C'est peut être lié au nom de la source modèle, je vais vérifié..
Essaie de faire plein de tests car, je te le rappelle, ça a marché il y a une semaine
Il faut faire bien faire attention au nom du classeur modele, ça c'est une certitude et à son emplacement. Si tu savais définitivement comment tu le nommerais (le modèle) et où tu le rangerais, ça pourrait permettre de sécuriser cet asect là.
Oui c'était bien ça!
Du coup j'ai fait plein de test ..
Ajout d'une référence 4x.. à la suite OK
Ajout d'une référence entre 2 OK
Supprimé une ligne + mise à jour OK ( sauf cellule Fiche n°: "AV-***) en destination de nom de fiche qui ne suit pas)
En fait des lors qu'on supprime une ligne rine ne va plus dans les numéro de fiche
Sinon le reste nickel!!
En ce qui concerne l'emplacement il ne sera jamais au même endroit car chacun en auras une version dans son PC. Je peux seulement lui donner un nom fixe qui sera "Cahier de contrôle" mais même de ce côté on ne pourras même pas car il sera renommé a chaque chantier...ex: 696-56970 - Cahier de contrôle
Salut 3GB!
J'ai réussi a rectifié une erreur YOUPI!!
Il fallait que je relance la manip bouton pour pouvoir accéder au "répertoire" et " Réserve"
Cependant les insertions et suppressions.. je bloque..
Salut Willkaa,
Bravo !
Oui, je pense que les risques d'erreur portent sur l'insertion ou la suppression de fiches.
Le truc, c'est que j'ai saisi le code pour une utilisation "classique" et il est nécessaire (je me renseignerai quand même) d'avoir le nom du fichier modèle en dur dans le code. Et comme il s'agit d'un fichier modèle, il faut qu'il garde un nom générique de type "Fichier modèle"
Ensuite, pour le reste, c'est vrai que je t'ai un peu livré le fichier et le code sans mode d'emploi et que je n'ai pas blindé la gestion d'erreurs (code un peu long déjà). Mais, il faut faire attention à certaines choses (ne pas supprimer de feuilles autrement que par la macro mise à jour, ne pas renommer de feuilles dans le classeur modèle ni dans le nouveau cahier, ne pas insérer de lien hypertexte manuellement sur l'onglet répertoire, ...).
Il faut aussi surveiller que la formule en colonne A se répande correctement après une insertion de lignes. Ce sont tout un tas de petits détails qui rendent la chose complexe.
Je regarderai à nouveau quand j'aurai suffisamment de temps pour le faire. Mais l'idéal serait que tu parviennes à détecter toutes les causes de problème.