Discussion :

[jpg35]

Bonjour à tous,

J'ai un petit soucis.

Je travaille depuis plusieurs mois sur un classeur excel "recette standard" que je duplique pour créer différentes recettes indépendantes.

Tous rangés dans un même dossier.

Aujourd'hui, j'ai ajouté une feuille dans mon classeur "recette standard" que j'aimerais copier dans mes recettes existantes, tout ceci sans liaison bien sûr !

Je me suis risqué à un code en essayant de déchiffrer d'autres macros qui se rapprochent un peu de l'utilité que je veux en faire.

Mais vous allez vite vous rendre compte que je suis totalement novice !

Voici ce que je propose:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
 
Option Explicit
 
Dim FichierPrincipal As Workbook
 
Sub CompilRecettes()
 
Dim fs
Dim chemin As Folder
 
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set chemin = fs.GetFolder(ThisWorkbook.Path)
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set FichierPrincipal = ThisWorkbook
    Call scan(chemin)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
 
End Sub
 
Sub scan(ByVal Dossier As Folder)
 
Dim Fichier As File
Dim Sousdossier As Folder
Dim Classeur As Workbook
 
    For Each Fichier In Dossier.Files
        Select Case Right(Fichier, 3)
            Case "xls", "lsx", "lsm", "lsb"
                If Left(Fichier.Name, 1) <> "~" And Not (Fichier.Name Like "*Recette standard*") Then
                    Workbooks.Open Fichier
                    Set Classeur = ActiveWorkbook
                        ActiveWorkbook.Sheets(4).Select
                        FichierPrincipal.Activate
                        Selection.Copy
                    End If
 
                    Classeur.Close False
                End Ifhttps://forum.excel-pratique.com/post/nouveau/2#
        End Select
    Next Fichier
 
    For Each Sousdossier In Dossier.SubFolders
        Call scan(Sousdossier)
    Next
 
End Sub

Merci pour votre aide !

jp

[EricDgn]

Bonjour,

A tester, en partant par précaution d'un dossier ne contenant que quelques fichiers:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Option Explicit
 
Sub CompilRecettes()
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Scan fs.GetFolder(ThisWorkbook.Path)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 
Sub Scan(Dossier)
    Dim Fichier As Object, SousDossier As Object, Classeur As Workbook
    For Each Fichier In Dossier.Files
        Select Case Right(Fichier.Path, 3)
            Case "xls", "lsx", "lsm", "lsb"
                If Left(Fichier.Name, 1) <> "~" And Not (Fichier.Name Like "*Recette standard*") Then
                    Debug.Print Fichier.Path
                    Set Classeur = Workbooks.Open(Fichier)
                    ActiveSheet.Copy Before:=Classeur.Sheets(1)   '--- recopie la feuille active dans classeur, en première place
                    Classeur.Close SaveChanges:=True
                End If
        End Select
    Next Fichier
    For Each SousDossier In Dossier.Subfolders
        Scan SousDossier
    Next
End Sub

Cordialement.

[Pierre Fauconnier]

Salut.

Attention que lorsque l'on ouvre un classeur, il devient le classeur actif, de sorte que le ActiveSheet qui suit pointe vers le classeur que l'on vient d'ouvrir et pas vers le classeur d'origine.

Perso, je passerais par une variable As Worksheet avant la boucle, et c'est cette feuille que je copierais

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub Scan(Dossier)
    Dim Fichier As Object, SousDossier As Object, Classeur As Workbook, sh As Worksheet
 
    set sh = activesheet ' ou celle du classeur source que l'on veut copier
    For Each Fichier In Dossier.Files
        Select Case Right(Fichier.Path, 3)
            Case "xls", "lsx", "lsm", "lsb"
                If Left(Fichier.Name, 1) <> "~" And Not (Fichier.Name Like "*Recette standard*") Then
                    Debug.Print Fichier.Path
                    Set Classeur = Workbooks.Open(Fichier)
                    sh.Copy Before:=Classeur.Sheets(1)   '--- recopie la feuille choisie en première place des feuilles du classeur cible
                    Classeur.Close SaveChanges:=True
                End If
        End Select
    Next Fichier
    For Each SousDossier In Dossier.Subfolders
        Scan SousDossier
    Next
End Sub

Pourrais-tu préciser ce que tu veux dire par "sans liaisons"? Dans ta question initiale, tu parles des fichiers qui sont dans "un même dossier". Pourquoi scannes-tu les sous-dossiers? Au lieu de code, peux-tu nous préciser ce que tu souhaites réaliser "comme si tu rédigeais un cahier des charges dans connaissances d'Excel et de VBA"?


NB: A noter que l'on peut scanner les sous-dossiers avec DIR pour ne scanner que les xls* et donc rester en VBA sans passer par le FileSystemObject.

[jpg35]

Merci à vous deux pour votre aide !

Je vais essayer d'être un peu plus clair dans ma demande.

Pourrais-tu préciser ce que tu veux dire par "sans liaisons"? Dans ta question initiale, tu parles des fichiers qui sont dans "un même dossier". Pourquoi scannes-tu les sous-dossiers?

Je travaille de la façon suivante:

J'ai un classeur "Recette standard" qui me sert de trame vierge pour l'élaboration de mes recettes.
A chaque fois que je crée une recette, je copie ce classeur et le renomme pour devenir "Recette 1", "Recette 2"...
Aujourd’hui, je suis obligé d'ajouter une nouvelle feuille nommée "FICHE RECETTE" à "Recette standard". Celle ci me servira pour toutes mes recettes à venir.
Mon problème est d'incorporer cette nouvelle feuille dans mes anciennes recettes qui commencent à être nombreuses!

C'est pour cela que je souhaite la copier "sans liaison", je veux que les nouvelles feuilles copiées dans leur classeur respectif n'aient plus de lien avec "Recette standard".

Tous les classeurs sont effectivement rangés dans un même dossier actuellement, mais je n'exclue pas un jour de créer des sous-dossiers, c'est pourquoi je les scan effectivement les sous-dossiers.

Je joins un dossier qui devrait être parlant.

[Pierre Fauconnier]

Je n'ai pas de quoi dézipper un 7z.

Les liaisons sont de quel type? Formules? Vers d'autres feuilles du même classeur? Vers un autre classeur? As-tu testé les solutions proposées?

[jpg35]

Bonjour,

J'ai un peu ramé, mais vos propositions marchent bien !

J'ai adapté très légèrement et voici ce que ça donne:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
 
Option Explicit
 
Sub CompilRecettes()
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Scan fs.GetFolder(ThisWorkbook.Path)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 
Sub Scan(Dossier)
    Dim Fichier As Object, SousDossier As Object, Classeur As Workbook, sh As Worksheet
 
    Set sh = Sheets(4)  ' ou celle du classeur source que l'on veut copier
    For Each Fichier In Dossier.Files
        Select Case Right(Fichier.Path, 3)
            Case "xls", "lsx", "lsm", "lsb"
                If Left(Fichier.Name, 1) <> "~" And Not (Fichier.Name Like "*Recette standard*") Then
                    Debug.Print Fichier.Path
                    Set Classeur = Workbooks.Open(Fichier)
                    sh.Copy Before:=Classeur.Sheets(4)   '--- recopie la feuille choisie en première place des feuilles du classeur cible
                    Classeur.Close SaveChanges:=True
                End If
        End Select
    Next Fichier
    For Each SousDossier In Dossier.SubFolders
        Scan SousDossier
    Next
End Sub

Je crée bien une copie de ma feuille 4 dans chaque classeur existant ! Et c'est déjà très bien !

Le seul problème est que les feuilles crées conservent les liaisons vers le classeur "Recette standard".

Par exemple, les formules que je retrouve dans ces nouvelles feuilles ressemblent à: ='[Recette standard.xlsm]Renseignements'!A11

Je souhaiterais idéalement arriver à :='Renseignements'!A11

Est-ce possible?

Bonne journée,

jp

[EricDgn]

Bonjour,

Une façon de faire est de supprimer ces liens dans la feuille copiée.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Option Explicit
 
Dim shFR As Worksheet, sLink As String
 
Sub CompilRecettes()
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set shFR = Sheets("FICHE RECETTE")          ' feuille que l'on veut copier
    sLink = "[" & ThisWorkbook.Name & "]"       ' partie du lien à supprimer dans la copie
    Set wB = ThisWorkbook
    Scan fs.GetFolder(ThisWorkbook.Path)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 
Private Sub Scan(Dossier)
    Dim Fichier As Object, SousDossier As Object, Classeur As Workbook
    For Each Fichier In Dossier.Files
        Select Case Right(Fichier.Path, 3)
            Case "xls", "lsx", "lsm", "lsb"
                If Left(Fichier.Name, 1) <> "~" And Not (Fichier.Name Like "*Recette standard*") Then
                    Debug.Print Fichier.Path
                    Set Classeur = Workbooks.Open(Fichier)
                    '--- recopie la feuille choisie en 4e place des feuilles du classeur cible
                    shFR.Copy Before:=Classeur.Sheets(4)
                    '--- supprime les liens au fichier de départ
                    Cells.Replace What:=sLink, Replacement:="", LookAt:=xlPart, _
                                  SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                                  ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
                    '--- ferme en sauvant
                    Classeur.Close SaveChanges:=True
                End If
        End Select
    Next Fichier
    For Each SousDossier In Dossier.SubFolders
        Scan SousDossier
    Next
End Sub

Avec Excel 365, bien qu'il y ait DisplayAlerts = False, il y a une demande de confirmation à chaque copie de feuille!?

Cordialement.

[jpg35]

Merci,

Je ne comprends pas, ça bloque sur:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

FormulaVersion:=xlReplaceFormula2

Le débogueur me dit qu'il manque une variable non déclarée...

[EricDgn]

Bonjour,

Sans doute un problème lié à la version d'excel. Essayer en remplaçant les lignes 29-30-31 du code par celle-ci:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

                    Cells.Replace What:=sLink, Replacement:="", LookAt:=xlPart

Cordialement.