XL 2019 Dupliquer un onglet identique de 200 classeurs dans un seul classeur avec 200 onglets

[nicolino]

Bonsoir,

Tout est dans le titre (ou presque)

Je suis assez novice et c'est mon premier post.

J'aimerai trouver la bonne macro pour réaliser cette tâche très monotone manuellement (j'en suis à une centaine de classeurs et je craque à les ouvrir un à un...) qui consiste à dupliquer un onglet identique nommé "PHOTOS" de plusieurs classeurs "fichier n°1.xlsx" et "fichier n°2.xlsx" dans un seul classeur "Fichier complet.xlsx" avec tous les onglets à la suite mais renommés.

Exemple fichiers en PJ:

• fichier n°1.xlsx
• fichier n°2.xlsx
• Fichier complet.xlsx

J'aimerai copier l'onglet PHOTOS du fichier n°1 et l'onglet PHOTOS du fichier n°2 dans le classeur Fichier complet en renommant les onglets avec le texte présent dans la cellule A2.

fichier n°1.xlsx

fichier n°2.xlsx

Fichier complet.xlsx

Un grand merci par avance pour votre aide

Nicolas

 

[job75]

Bonsoir nicolino, bienvenue sur XLD,

Téléchargez les fichiers joints dans le même dossier (le bureau).

Et sur le fichier Fichier complet(1).xlsm cliquez sur le bouton pour exécuter cette macro :

Sub Consolider()
Dim chemin$, fichier$, w As Worksheet
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
'---suppression des feuilles PHOTOS---
For Each w In Worksheets
    If UCase(w.Name) Like "PHOTOS*" Then w.Delete
Next
'---copie des fichiers---
While fichier <> ""
    With Workbooks.Open(chemin & fichier)
        Err = 0
        .Sheets("PHOTOS").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        If Err = 0 Then ThisWorkbook.ActiveSheet.Name = "PHOTOS " & Left(.Name, Len(.Name) - 5)
        .Close False
    End With
    fichier = Dir 'fichier suivant
Wend
Sheets(1).Select
End Sub

Avec 200 fichiers à ouvrir et copier la durée d'exécution sera assez longue.

Bonne nuit.

 

[job75]

Bonjour nicolino, le forum,

On remarquera que je n'utilise pas le texte situé en A2 pour nommer les feuilles.

En effet ce texte peut être erroné : sans le mot PHOTOS ou en doublon.

A+

 

[nicolino]

Bonjour nicolino, le forum,

On remarquera que je n'utilise pas le texte situé en A2 pour nommer les feuilles.

En effet ce texte peut être erroné : sans le mot PHOTOS ou en doublon.

A+

Bonjour @job75 !

Un grand merci pour votre rapide réponse et la macro, c'est super efficace !

J'ai réussi à reproduire la macro sur mon fichier de travail mais en effet je n'arrive pas à renommer les onglets comme je le souhaitais, je cherche une solution...

En fait dans mes cellules A2, j'ai ce texte : "Photos du poteau n°XXXXX", ce que j'aurai aimé dans le nom de l'onglet.

Si vous avez un tuyau je suis preneur !

Merci

Bien à vous

 

[job75]

Je vois qu'il y a un onglet nommé "photos", avec ma macro du post #2 ce n'est pas possible car il est supprimé.

Maintenant si vous voulez absolument nommer l'onglet avec le texte en A2 utilisez :

Sub Consolider()
Dim chemin$, fichier$, w As Worksheet
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
'---suppression des feuilles PHOTOS---
For Each w In Worksheets
    If UCase(w.Name) Like "PHOTOS*" Then w.Delete
Next
'---copie des fichiers---
While fichier <> ""
    With Workbooks.Open(chemin & fichier)
        .Sheets("PHOTOS").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        ThisWorkbook.ActiveSheet.Name = .Sheets("PHOTOS").Range("A2")
        .Close False
    End With
    fichier = Dir 'fichier suivant
Wend
Sheets(1).Select
End Sub

Mais comme je l'ai dit cela peut être source d'erreurs.

 

[nicolino]

Merci beaucoup @job75 !

Vous venez de me faire gagner quelques heures de "copier-coller" fastidieux !

Votre macro fonctionne à merveille

 

[nicolino]

J'ai encore une interrogation mais je ne sais pas si je dois continuer à alimenter ce post ou créer un nouveau sujet ?

Maintenant que j'ai mes 200 onglets, je voudrais ajouter un lien hypertexte dans une colonne de mon tableau général qui pointe vers l'onglet correspondant (en fonction du numéro contenu dans la cellule A) :

Manuellement c'est assez long: clic droit, lien, dans ce document, puis trouver le bon onglet !

Je suis preneur d'une nouvelle idée de génie

Merci encore

 

[job75]

Ce n'est plus le même sujet, normalement il faudrait créer une nouvelle discussion.

Mais comme c'est vraiment très classique voici le code pour créer les liens en colonne B :

Sub Liens()
Dim c As Range, w As Worksheet
Application.ScreenUpdating = False
On Error Resume Next 'si une feuille n'existe pas
With ActiveSheet 'à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Range("B2:B" & .Rows.Count).Clear 'RAZ
    For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
        Set w = Nothing
        Set w = Sheets("Photos du poteau n°" & c)
        .Hyperlinks.Add c(1, 2), "", "'" & w.Name & "'!A1"
    Next
End With
End Sub

 

[nicolino]

Encore une fois merci pour ce retour, j'ai terminé mon rapport qui m'aurait pris 3 jours de plus !

Je sais maintenant ce que je vais faire de mon compte CPF en 2022 --> trouver une formation VBA

Bon weekend